Shiny - assigning argument to function - function

I am trying to create a shiny app that applies a self-made function to an uploaded dataset, then allows to download the modified results. Here is my code:
library(shiny)
library(tidyverse)
namkurz <- function(data, a_spalte) {
kuerzel <- vector(length = length(data$a_spalte))
for (i in 1:length(data$a_spalte)){
spez = data$Art[i]
s = unlist(strsplit(spez, " ", fixed = TRUE))
s = substr(s, 1, 2)
s = paste(s, collapse = ' ')
kuerzel[[i]] = s
}
data <- data %>%
mutate(kurz = kuerzel)
}
ui <- fluidPage(
fileInput('upload','Deine Kartierungsdaten'),
textInput('art', 'Wie heißt die Spalte mit Artnamen?'),
downloadButton('analyse','Artenkürzel hinzufügen')
)
server <- function(input, output, session) {
data <- reactive({
req(input$upload)
ext <- tools::file_ext(input$upload$name)
switch(ext,
csv = vroom::vroom(input$upload$datapath, delim = ";"),
validate("Invalid file; Please upload a .csv file")
)
})
art <- reactive(input$art)
output$analyse <- downloadHandler(
filename = function() {
paste0('mit_kuerzel', ".csv")
},
content = function(file) {
ergebnis <- reactive(namkurz(data(), art()))
vroom::vroom_write(ergebnis(), file)
}
)
}
shinyApp(ui, server)
When trying to save the output I get a 'Warning: Unknown or uninitialised column:' error. I think my problem is in the assignment of argument 'art' to the 'ergebnis' object, but I can't find the way to fix it.

I recommend a few things:
(Required) In your function, a_spalte is a character vector and not the literal name of column in the frame, so you need to use [[ instead of $, see The difference between bracket [ ] and double bracket [[ ]] for accessing the elements of a list or dataframe and Dynamically select data frame columns using $ and a character value.
Change all references of data$a_spalte to data[[a_spalte]].
namkurz <- function(data, a_spalte) {
kuerzel <- vector(length = length(data[[a_spalte]]))
for (i in 1:length(data[[a_spalte]])){
spez = data$Art[i]
s = unlist(strsplit(spez, " ", fixed = TRUE))
s = substr(s, 1, 2)
s = paste(s, collapse = ' ')
kuerzel[[i]] = s
}
data <- data %>%
mutate(kurz = kuerzel)
}
Your function is a bit inefficient doing things row-wise, we can vectorize that operation.
namkurz <- function(data, a_spalte) {
spez <- strsplit(data$Art, " ", fixed = TRUE)
data$kurz <- sapply(spez, function(z) paste(substr(z, 1, 2), collapse = " "))
data
}
(Optional) The content= portion of downloadHandler is already reactive, you do not need to wrap namkurz in reactive. Because of this, you also don't need to treat ergebnis as reactive.
output$analyse <- downloadHandler(
filename = ...,
content = function(file) {
ergebnis <- namkurz(data(), art())
vroom::vroom_write(ergebnis, file)
}
)
(Optional) Your output filename is fixed, so two things here: if it's always going to be "mit_kuerzel.csv", then there's no need for paste0, just use function() "mit_kuerzel.csv".
However, if you are intending to return a file named something based on the original input filename, one could do something like:
filename = function() {
paste0(tools::file_path_sans_ext(basename(input$upload$name)),
"_mit_kuerzel.",
tools::file_ext(input$upload$name))
},
to add _mit_kuerzel to the base portion of the uploaded filename. Note that the file in the content= section is never this name, the new_mit_kuerzel.csv is the filename offered to the downloading browser as a suggestion, that is all.
(Optional) You are using a .csv file extension in the downloadHandler, but the default for vroom::vroom_write is to use delim = "\t", which is not a CSV. I suggest either adding delim = ";" (or similar), or changing the returned filename extension to .tsv instead.

Related

How define Server for Copy/Paste regions as input in R/Shiny?

I have a shiny which can be used to overlap between query regions and a given data table (e.g. DF). I put two options for uploading query data 1) as .bed format and 2) inserting data as copy/paste.
The shiny works well with uploading .bed file but I am not sure how can I define Server for copy/paste (text) data.
Thank you in advance for any suggestion!
DF<- data.table(chr=c("chr1","chr2"),start=c(10,20),end=c(20,30))%>% setkey(chr, start, end)
text<- data.table(chr=c("chr1","chr2"),start=c(15,25),end=c(15,30))%>% setkey(chr, start, end)
ui <- fluidPage(
sidebarLayout(
sidebarPanel (
p(strong ("Find overlap between query file and data"),style = "color:blue;"),
br(),
selectInput("choose","Choose file source",choices = c("file","text"),selected = "file"),
conditionalPanel("input.choose=='file'",
fileInput("query.file", "Upload genomic coordinates in .bed
format:",multiple = F,accept = ".bed")),
conditionalPanel("input.choose=='text'",
textAreaInput("query.text", "Enter genomic coordinates:")),
actionButton("run", "run"),
width = "2"),
mainPanel(
dataTableOutput("DFtable"),
dataTableOutput("overlap_table"))
)
)
server <- function (input, output, session) {
## Read user .bed file
user_query.file <- reactive({
req(input$query.file)
ext <- tools::file_ext(input$query.file$name)
switch(ext,
bed = fread(input$query.file$datapath,header=F)%>%
dplyr::rename (chr =V1, start=V2, end=V3) %>% setkey(chr, start, end)%>% unique()
)
})
## overlapping between query file and table
overlap <- eventReactive(input$run, {
req(input$run)
withProgress(message = 'Analysis in progress', value = 0, {
query.overlap<- foverlaps(user_query.file() ,DF, nomatch = 0) %>%
unique()
})
})
## output
output$DFtable<- renderDataTable({ DF })
output$overlap_table <- renderDT({overlap () })
}
shinyApp(ui, server)
Desire out put using TEXT input option:
chr start end i.start i.end
chr1 15 15 10 20
chr2 25 30 20 30
Not sure on how your copied text looks like, but assuming something like:
chr,start,end
chr1,10,20
chr4,34,56
All you need is to parse the text contents of the UI input and assigned it to DF variable. Your run event handler could look like:
## overlapping between query file and table
overlap <- eventReactive(input$run, {
req(input$run)
#Requiring text input and parsing it
req(input$query.text)
DF <- data.table(read.csv(text=input$query.text)) %>% setkey(chr, start, end)
withProgress(message = 'Analysis in progress', value = 0, {
query.overlap<- foverlaps(text ,DF, nomatch = 0) %>%
unique()
})
})
Then when clicking on the run button, the analysis is executed and the overlap reactive value is updated. If the comparison is always between file and text provided, you should also include a req(user_query.file()) to ensure the file has been provided and correctly parsed.

R Shiny - Editing a data table inside a dynamically created bsModal

The app below contains an actionButton Add data that inserts a UI element each time it is clicked. Each UI element is a box that contains one selectInput Select data and an actionButton Edit that opens a modal when clicked.
Each modal contains:
A data table with two columns: Parameter and Value (this column is editable).
An actionButton Apply, which applies any changes made to the Value
column.
When the user selects a dataset inside box x, a reactiveValue is created to store the corresponding parameters in a data.frame x_paramset (where x is the id of the box inserted via insertUI) and add a val column which has the same value as default (see list at the top of code below). I then use renderDataTable to add the Value column (which contains the numericInput) - this data table is displayed inside the modal.
To update the data.frame to apply any changes the user may have made in the modal, I use an observeEvent that listens for the Apply button and updates the val column in the data.frame x_paramset with the values inside the numericInputs in the Value column.
Here is the app (the bsModal has been commented out and replaced with a shinyWidgets::dropdownButton):
library(shiny)
library(shinydashboard)
library(shinyjs)
library(shinyWidgets)
library(DT)
library(tidyverse)
all = list(p1 = list(a = list(id = "a", default = 10)),
p2 = list(x = list(id = "x", default = 20)))
# UI ----------------------------------------------------------------------
ui<-fluidPage(shinyjs::useShinyjs(),
tags$head(
tags$script("
$(document).on('click', '.dropdown-shinyWidgets li button', function () {
$(this).blur()
Shiny.onInputChange('lastClickId',this.id)
Shiny.onInputChange('lastClick',Math.random())
});
")
),
box(title = "Add data",
column(width = 12,
fluidRow(
tags$div(id = 'add')
),
fluidRow(
actionButton("addbox", "Add data")
))
)
)
# SERVER ------------------------------------------------------------------
server <- function(input, output, session) {
rvals = reactiveValues()
getInputs <- function(pattern){
reactives <- names(reactiveValuesToList(input))
name = reactives[grep(pattern,reactives)]
}
observeEvent(input$addbox, {
lr = paste0('box', input$addbox)
insertUI(
selector = '#add',
ui = tags$div(id = lr,
box(title = lr,
selectizeInput(lr, "Choose data:", choices = names(all)),
shinyWidgets::dropdownButton(inputId = paste0(lr, "_settings"),
circle = F, status = "success", icon = icon("gear"), width = "1000px",
tooltip = tooltipOptions(title = "Click to edit"),
tags$h4(paste0("Edit settings for Learner", lr)),
hr(),
DT::dataTableOutput( paste0(lr, "_paramdt") ),
bsButton(paste0(lr, "_apply"), "Apply")
) # end dropdownButton
)
) #end tags$div
) # end inserUI
# create reactive dataset
rvals[[ paste0(lr, "_paramset") ]] <- reactive({
do.call(rbind, all[[ input[[lr]] ]]) %>%
cbind(., lr) %>%
as.data.frame %>%
mutate(val = default)
}) # end reactive
# render DT in modal
output[[ paste0(lr, "_paramdt") ]] <- renderDataTable({
DT <- rvals[[ paste0(lr, "_paramset") ]]() %>%
mutate(
Parameter = id,
Value = as.character(numericInput(paste0(lr,"value",id), label = NULL, value = default))) %>%
select(Parameter:Value)
datatable(DT,
selection = 'none',
#server = F,
escape = F,
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
}) # end renderDT
# Apply changes
observeEvent(input$lastClick, {
# replace old values with new
rvals[[ paste0(lr, "_paramset") ]](rvals[[ paste0(lr, "_paramset") ]]() %>%
mutate(
val = input$box1valuea
)
)
}) # end apply changes observeEvent
}) #end observeEvent
}
shinyApp(ui=ui, server=server)
I encounter errors when I try the following:
Add data >> Edit >> make some change to numericInput >> Apply - this
resets the numericInput inside the modal back to its default whereas
I would like the user-specified value to persist upon applying
changes or closing the modal.
The app crashes when I try:
Add data >> Edit >> Apply >> close modal >> Add data OR
Click Add data twice and then click Edit in either box.
I am not sure where my server logic is failing. I know Shiny does not support "persistent use" modals (https://github.com/rstudio/shiny/issues/1590) but I was wondering if there was a workaround? I am also not sure what inside the insertUI observeEvent is causing the app to crash in the cases described above. Any help you can offer would be greatly appreciated!

How to create html table including images with R (via relative path or inserted - base64)?

I found a solution to this in the past and still using it but I never looked for something else. I would like to share this one and get some feedback from the community about this and if better solution exists.
Actually my next idea on this is to implement selection tool a bit like editableCell. I actuallz could do it but the main raison to use this would be to use copy paste to paste the picture somewhere else as they are positioned. Unfortunately it does not copy the picture.
I have a list of jpeg with a specific name:
010003000Color3_0.jpg
010003000Color3_1.jpg
010003000Color3_2.jpg
I need to get the information from those names are create a grid of those pictures depending on the information contained.
E.g. here I have a name corresponding to _.jpg
Here the complete code, I let you go through it. Read the comments that are partly explaining it.
# Setup -------------------------------------------------------------------
library(data.table)
library(dplyr)
library(tableHTML)
library(knitr)
wd <- "C:/Users/gravier/Downloads/Example_Yann_Html/Jpeg"
# Function ----------------------------------------------------------------
addimgbalise <- function(vect, pisize=200) {
# to add a html balise with a pixel size for the image
vect <- paste0("<img src='", vect,"' width=", pisize, "/>")
return(vect)
}
write.html.link <- function(data,
filename,
caption = filename,
wdfunction,
color.bg = "#00000",
color.line = "#b4bac4",
color.text = "#b4bac4",
font.size = "8px",
font.family = "Arial",
text.align = "center") {
# permit to write a html table with a local link to click
tabhtml <- tableHTML(data,
rownames = FALSE,
caption = caption,
theme="default") %>%
add_css_table(css = list('border', color.line)) %>%
add_css_table(css = list('text-align', text.align)) %>%
add_css_table(css = list('font-family', font.family)) %>%
add_css_table(css = list('font-size', font.size)) %>%
add_css_table(css = list('color', color.text))
write_tableHTML(tabhtml, file = paste0(wdfunction, "/", filename, ".html"))
# unfortunately write_tableHTML has been changed in the past and is not write the '<' '>' characters of the addimgbalise function, so we have to read again the html and exchange those characters again
temp <- suppressWarnings(readLines(paste0(wdfunction, "/", filename, ".html")))
temp <- gsub( ">", ">", temp)
temp <- gsub( "<", "<", temp)
temp <- c("<body bgcolor='", color.bg, "'>", temp)
writeLines(temp, paste0(wdfunction, "/", filename, ".html"))
}
# Parameters (where in function normally, but I detail the process --------
patternlist <- ".jpg"
regexjpeg <- "([0-9]*)(.*)_(.*)" # this the regex expression regarding the name of the files
regexposID <- "\\1" # position of the different variable I want to extract from the name
regexposWhat <- "\\2"
regexposField <- "\\3"
regexposZ <- "\\3"
formulaPV <- "row+Field~col+What" # then the dcast formula regarding how to arrange the pictures
pixelimg <- 150 # size in html but the picture are kept of real resolution so you can zoom
base64 <- F
listimg<- data.table(path = list.files(wd, full.names = T))
listimg[, ID := gsub(paste0(regexjpeg, patternlist), regexposID, basename(path))]
listimg[, What := gsub(paste0(regexjpeg, patternlist), regexposWhat, basename(path))]
listimg[, Field := as.numeric(gsub(paste0(regexjpeg,patternlist), regexposField, basename(path)))]
listimg[, Z := as.numeric(gsub(paste0(regexjpeg,patternlist), regexposZ, basename(path)))]
listimg[, row := LETTERS[as.numeric(substr(ID, 1, 3))]]
listimg[, col := as.numeric(substr(ID, 4, 6))]
if( base64 ) {
for(i in 1:nrow(listimg) ) {
listimg[i, code := paste0(addimgbalise(image_uri(path), pixelimg), "\n", row, col, "-", Field, "-", What)]
}
} else {
listimg[, code := paste0(addimgbalise(path, pixelimg), "\n", row, col, "-", Field, "-", What)]
}
listimg3 <- dcast(listimg, as.formula(formulaPV), value.var = "code")
listimg3 <- data.frame(listimg3)
listimg3[nrow(listimg3)+1,] <- colnames(listimg3)
write.html.link(data = listimg3, filename = "Picture_grid", caption = paste0("Picture_grid", " - ", formulaPV), wdfunction = dirname(wd))
# Some other example ------------------------------------------------------
formulaPV <- "row+Field+What~col" # then the dcast formula regarding how to arrange the pictures
listimg3 <- dcast(listimg, as.formula(formulaPV), value.var = "code")
listimg3 <- data.frame(listimg3)
listimg3[nrow(listimg3)+1,] <- colnames(listimg3)
write.html.link(data = listimg3, filename = "Picture_grid_other_formula", caption = paste0("Picture_grid", " - ", formulaPV), wdfunction = dirname(wd))
# base64
for(i in 1:nrow(listimg) ) {
listimg[i, code := paste0(addimgbalise(image_uri(path), pixelimg), "\n", row, col, "-", Field, "-", What)]
}
listimg3 <- dcast(listimg, as.formula(formulaPV), value.var = "code")
listimg3 <- data.frame(listimg3)
listimg3[nrow(listimg3)+1,] <- colnames(listimg3)
write.html.link(data = listimg3, filename = "Picture_grid_base64", caption = paste0("Picture_grid", " - ", formulaPV), wdfunction = dirname(wd))
The final result is like this:

IMF data downloading bug

I'm facing bug, which starting to make me really nervous.
So, begin from the start: I writed a code, which downloads data from IMF DOT (countries export ad import data).
Sometime this code works (downloads all data). Sometime. Other time, in middle of downloading i get error:
No encoding supplied: defaulting to UTF-8.
Error: lexical error: invalid char in json text.
<!DOCTYPE HTML PUBLIC "-//W3C//
(right here) ------^
What is funny there - sometime error happens in the beggining of downloading, sometime in the middle. Basically, it comes random. So debugging it is basically fighting with shadow. Maybe anyone has faced with this problem also and can help?
Code:
rm(list = ls())
#Code downloads data from DOT (IMF).
#DOT(date).csv
# Libraries
suppressPackageStartupMessages(library(plyr))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(tidyr))
suppressPackageStartupMessages(library(reshape2))
suppressPackageStartupMessages(library(stringr))
suppressPackageStartupMessages(library(IMFData))
suppressPackageStartupMessages(library(TTR))
suppressPackageStartupMessages(library(readxl))
#Parameters of download -------------------------------------------------------
databaseID <- 'DOT'
startdate <- '1977-01-01'
enddate <- format(Sys.Date(),"%Y-%m-%d")
checkquery = FALSE
# Frequency
download.freq <- c("A")
# Area
available.codes <- DataStructureMethod('DOT')
cn <- available.codes$CL_AREA_DOT
# Download data -----------------------------------------------------------
print("Downloading")
datalist <- list(); queryfilter<- list()
for(i in 1:length(cn[,"CodeValue"])) queryfilter[[i]] <- list(CL_FREA=download.freq, CL_AREA_DOT=cn[,"CodeValue"][i], CL_INDICATOR_DOT = "TXG_FOB_USD"
)
datalist<- plyr::llply(queryfilter, function(x) {
Sys.sleep(runif(1,2,5))
Dot.downloader(databaseID,x, startdate, enddate)
}, .progress = "text")
#WHERE ERRORS HAPPENS
data <- do.call(rbind.data.frame, datalist) #..............................................................................................................................................................................................................................................
Oh and Dot.downloader function looks like this (it is from IMFdata library, just a bit adapted to the situation):
Dot.downloader <- function(databaseID, queryfilter=NULL,
startdate='1977-01-01', enddate='2016-12-31'){
queryfilterstr <- ''
if (length(queryfilter) > 0){
queryfilterstr <- paste0(
unlist(plyr::llply(queryfilter,
function(x)(paste0(x, collapse="+")))), collapse=".")
}
APIstr <- paste0('http://dataservices.imf.org/REST/SDMX_JSON.svc/CompactData/',
databaseID,'/',queryfilterstr,
'?startPeriod=',startdate,'&endPeriod=',enddate)
r <- httr::GET(APIstr)
if(httr::http_status(r)$reason != "OK"){
stop(paste(unlist(httr::http_status(r))))
return(list())
}
r.parsed <- jsonlite::fromJSON(httr::content(r, "text"))
if(is.null(r.parsed$CompactData$DataSet$Series)){
warning("No data available")
return(NULL)
}
if(class(r.parsed$CompactData$DataSet$Series) == "data.frame"){
r.parsed$CompactData$DataSet$Series <- r.parsed$CompactData$DataSet$Series[!plyr::laply(r.parsed$CompactData$DataSet$Series$Obs, is.null),]
if(nrow(r.parsed$CompactData$DataSet$Series) ==0){
warning("No data available")
return(NULL)
}
}
if(class(r.parsed$CompactData$DataSet$Series) == "list"){
if(is.null(r.parsed$CompactData$DataSet$Series$Obs)){
warning("No data available")
return(NULL)
}
ret.df <- as.data.frame(r.parsed$CompactData$DataSet$Series[1:(length(r.parsed$CompactData$DataSet$Series)-1)])
ret.df$Obs <- list(r.parsed$CompactData$DataSet$Series$Obs)
names(ret.df) <- names(r.parsed$CompactData$DataSet$Series)
r.parsed$CompactData$DataSet$Series <- ret.df
}
return(r.parsed$CompactData$DataSet$Series)
}

R: Parsing group of html files with loop

The following code works for individual .html files:
doc <- htmlParse("New folder/1-4.html")
plain.text <- xpathSApply(doc, "//td", xmlValue)
plain.text <- gsub("\n", "", plain.text)
gregexpr("firstThing", plain.text)
firstThing <- substring(plain.text[9], 41, 50)
gregexpr(secondThing, plain.text)
secondThing <- substring(plain.text[7], 1, 550)
But the following loop does not and gives me the error:
XML content does not seem to be XML
file.names <- dir(path = "New folder")
for(i in 1:length(file.names)){
doc <- htmlParse(file.names[i])
plain.text <- xpathSApply(doc, "//td", xmlValue)
gsub("\n", "", plain.text)
firstThing[i] <- substring(plain.text[9], 41, 50)
secondThing[i] <- substring(plain.text[7], 1, 550)
}
I'm simply trying to extract the information (as I've been able to do in the first batch of code), and create a vector of information.
Any ideas on how to resolve this issue?
Two things. First, your paths were wrong. To fix this, use:
filenames = dir(path = "New folder", full.names = TRUE)
Secondly, a better way than filling two variables inside a for loop is to generate structured data in a list function:
result = lapply(filenames, function (filename) {
doc = htmlParse(filename)
plain_text = xpathSApply(doc, "//td", xmlValue)
c(first = substring(plain_text[9], 41, 50),
second = substring(plain_text[7], 1, 550))
})
Now result is a list of elements, where each element is a vector with names first and second.
A few other remarks:
Be wary of dots in variable names — S3 uses dots in names to determine the class of a generic method. Using dots for anything else in variable names causes confusion and should be avoided.
The gsub statement in your loop has no effect.