Below is a simplified version of my code. I'm simply trying to get Shiny to pass an input value to an rmongodb query, run the query based on the user input, and then plot the mean of a variable. The code below includes everything needed to replicate my issue, including insertion of documents into the collection.
I'd be very grateful for any help! I'm pulling my hair out (and there wasn't much left to begin with). I suspect that I'm placing the reactive() command inappropriately or something along those lines.
Many thanks to whoever can provide assistance.
#Install required packages and call each
library(devtools)
install_github(repo = "mongosoup/rmongodb")
library(rmongodb)
library(shiny)
#Establish connection with mongodb, check status, name database and collection, insert some documents, return one document
mongo <- mongo.create()
mongo.insert(mongo, "simpledb.main",'{"user":"Joe", "age":34}')
mongo.insert(mongo, "simpledb.main",'{"user":"Joe", "age":31}')
mongo.insert(mongo, "simpledb.main",'{"user":"Joe", "age":53}')
mongo.insert(mongo, "simpledb.main",'{"user":"Kate", "age":29}')
mongo.insert(mongo, "simpledb.main",'{"user":"Lisa", "age":21}')
mongo.insert(mongo, "simpledb.main",'{"user":"Henry", "age":34}')
mongo.insert(mongo, "simpledb.main",'{"user":"David", "age":43}')
if(mongo.is.connected(mongo) == TRUE) {
help("mongo.count")
mongo.count(mongo, "simpledb.main")
}
if(mongo.is.connected(mongo) == TRUE) {
mongo.find.one(mongo, "simpledb.main")
}
#Code needed for Shiny UI
ui <- fluidPage(
fluidRow(
column(2, textInput(inputId = "userName", label = "", value = "Enter name here"))),
mainPanel(plotOutput(outputId = "main_plot"))
)
#Code needed for Shiny server
server <- function(input, output) {
queryReactive <- reactive({
nameFinal <- paste0(input$userName)
query = mongo.bson.buffer.create()
mongo.bson.buffer.append(query, "user", nameFinal)
query = mongo.bson.from.buffer(query)
})
#Run the query and store results as an R list object
queryresults <- mongo.find.all(mongo=mongo, ns = coll, query=queryReactive)
#Convert the R list object into a data frame
resultsdf <- data.frame(matrix(unlist(queryresults), nrow=length(queryresults), byrow=T), stringsAsFactors=FALSE)
output$main_plot <- renderPlot({boxplot(as.numeric(resultsdf$X3))})
}
#Code needed to call Shiny UI and server
shinyApp(ui = ui, server = server)
There is no need for a reactive command in your server function. I have simplified and corrected your function below:
server <- function(input, output) {
output$main_plot <- renderPlot({
nameFinal <- paste0(input$userName)
query = mongo.bson.buffer.create()
mongo.bson.buffer.append(query, "user", nameFinal)
query = mongo.bson.from.buffer(query)
queryresults <- mongo.find.all(mongo=mongo, ns = "simpledb.main", query=query)
if (length(queryresults) > 0) {
resultsdf <- data.frame(matrix(unlist(queryresults), nrow=length(queryresults), byrow=T), stringsAsFactors=FALSE)
boxplot(as.numeric(resultsdf$X3))
}
else boxplot(c(0))
})
}
Related
Hi I am having issues regarding a foreach loop where in every iteration I estimate a regression on a subset of the data with a different list of controls on several outcomes. The problem is that for some outcomes in some countries I only have missing values and therefore the regression function returns an error message. I would like to be able to run the loop, get the output with NAs or a string saying "Error" for example instead of the coefficient table. I tried several things but they don't quite work with the .combine = rbind option and if I use .combine = c I get a very messy output. Thanks in advance for any help.
reg <- function(y, d, c){
if (missing(c))
feols(as.formula(paste0(y, "~ 0 + treatment")), data = d)
else {
feols(as.formula(paste0(y, "~ 0 + treatment + ", c)), data = d)
}
}
# Here we set up the parallelization to run the code on the server
n.cores <- 9 #parallel::detectCores() - 1
#create the cluster
my.cluster <- parallel::makeCluster(
n.cores,
type = "PSOCK"
)
# print(my.cluster)
#register it to be used by %dopar%
doParallel::registerDoParallel(cl = my.cluster)
# #check if it is registered (optional)
# foreach::getDoParRegistered()
# #how many workers are available? (optional)
# foreach::getDoParWorkers()
# Here is the cycle to parallel regress each outcome on the global treatment
# variable for each RCT with strata control
tables <- foreach(
n = 1:9, .combine = rbind, .packages = c('data.table', 'fixest'),
.errorhandling = "pass"
) %dopar% {
dt_target <- dt[country == n]
c <- controls[n]
est <- lapply(outcomes, function(x) reg(y = x, d = dt_target, c))
table <- etable(est, drop = "!treatment", cluster = "uid", fitstat = "n")
table
}
Is it possible to save and restore selections of a shinyTree?
I found a solution deleting the selections
R Shiny - Updating shinyTree node selections
but I need to save the selections and restore them later for example, by an actionButton
This is not possible with shinyTree only. Some functions of the underlying jsTree library have to be called directly and the values passed from JavaScript to R and vice-versa.
I made a small example, which should help you as a starting point.
If you save a selection via button-click, R sends a custom message to JavaScript, which will get the selected IDs and returns it to R via Shiny.setInputValue.
The selected ID's are then saved in the reactiveValues selectionRV, but you could save them in a file or database if needed.
library(shiny)
library(shinyTree)
library(shinyjs)
js <- HTML("
$(document).on('shiny:connected', function(event) {
Shiny.addCustomMessageHandler('saveselection', function(e) {
var selection = $('#tree').jstree().get_selected();
Shiny.setInputValue('treeselection', selection, {priority: 'event'});
});
})
")
## ui ####################
ui <- fluidPage(
useShinyjs(),
tags$head(tags$script(js)),
actionButton("deselect", "Deselect all"),
actionButton("savesele", "Save Selection"),
actionButton("restoresele", "Restore Selection"),
shinyTree("tree", dragAndDrop = TRUE,types= #Types is in the same format that jstree expects
"{
'#': { 'max_children' : 2, 'max_depth' : 4, 'valid_children' : ['root'] },
'root' : { 'valid_children' : ['file'] },
'default' : { 'valid_children' : ['default','file'] },
'file' : { 'icon' : 'fa fa-file', 'valid_children' : [] }
}"
)
)
## server ####################
server <- function(input, output, session) {
treeData <- reactive({
rootstrc <- structure(list(
SubListA = structure(list(
leaf1 = structure("",sttype="file",sticon="fa fa-signal"),
leaf2 = structure("",sttype="file",sticon="fa fa-signal"),
leaf3 = structure("",sttype="file",sticon="fa fa-signal")),
sttype="root",stopened=F,sticon="fa fa-signal"
),
SubListB = structure(list(
leafA = structure("",sttype="default",sticon="glyphicon glyphicon-leaf"),
leafB = structure("",sttype="default",sticon="shinyTree/icon.png"),
leafC = structure("",sttype="default",sticon="fa fa-signal")
),stopened=F,sttype="root",sticon="fa fa-signal")
),
sttype="root",stopened=F,sticon="fa fa-signal"
)
list(
root1 = rootstrc,
root2 = rootstrc,
root3 = rootstrc,
root4 = rootstrc
)
})
output$tree <- renderTree({
treeData()
})
selectionRV <- reactiveValues(list = NULL)
observeEvent(input$deselect, {
runjs("$('#tree').jstree().deselect_all()")
})
observeEvent(input$savesele, {
session$sendCustomMessage("saveselection", message)
})
observeEvent(input$restoresele, {
req(input$treeselection)
tmp <- paste0("[", paste(input$treeselection, collapse = ","), "]")
js <- sprintf("$('#tree').jstree().select_node(%s)", tmp)
runjs(js)
})
}
shinyApp(ui, server)
I am building a simple prototype wherein I am reading data from Pubsub and using BeamSQL, code snippet as below
val eventStream: SCollection[String] = sc.pubsubSubscription[String]("projects/jayadeep-etl-platform/subscriptions/orders-dataflow")
.withFixedWindows(Duration.standardSeconds(10))
val events: SCollection[DemoEvents] = eventStream.applyTransform(ParDo.of(new DoFnExample()))
events.map(row=>println("Input Stream:" + row))
val pickup_events = SideOutput[DemoEvents]()
val delivery_events = SideOutput[DemoEvents]()
val (mainOutput: SCollection[DemoEvents], sideOutputs: SideOutputCollections)= events
.withSideOutputs(pickup_events, delivery_events)
.flatMap {
case (evts, ctx) =>
evts.eventType match {
// Send to side outputs via `SideOutputContext`
case "pickup" => ctx.output(pickup_events,evts)
case "delivery" => ctx.output(delivery_events,evts)
}
Some(evts)
}
val pickup: SCollection[DemoEvents] = sideOutputs(pickup_events)
val dropoff = sideOutputs(delivery_events)
pickup.map(row=>println("Pickup:" + row))
dropoff.map(row=>println("Delivery:" + row))
val consolidated_view = tsql"select $pickup.order_id as orderId, $pickup.area as pickup_location, $dropoff.area as dropoff_location , $pickup.restaurant_id as resturantId from $pickup as pickup left outer join $dropoff as dropoff ON $pickup.order_id = $dropoff.order_id ".as[Output]
consolidated_view.map(row => println("Output:" + row))
sc.run().waitUntilFinish()
()
I am using Directrunner for testing it locally and I am able to see the results right until the beam sql is executed. The output from beam sql is not getting printed.
Input Stream:DemoEvents(false,pickup,Bangalore,Indiranagar,1566382242,49457442008,1566382242489,7106576,1566382242000,178258,7406545542,,false,null,htr23e22-329a-4b05-99c1-606a3ccf6a48,972)
Pickup:DemoEvents(false,pickup,Bangalore,Indiranagar,1566382242,49457442008,1566382242489,7106576,1566382242000,178258,7406545542,,false,null,htr23e22-329a-4b05-99c1-606a3ccf6a48,972)
Input Stream:DemoEvents(false,delivery,Bangalore,Indiranagar,1566382242,49457442008,2566382242489,7106576,1566382242000,178258,7406545542,,false,null,htr23e22-329a-4b05-99c1-606a3ccf6a48,972)
Delivery:DemoEvents(false,delivery,Bangalore,Indiranagar,1566382242,49457442008,2566382242489,7106576,1566382242000,178258,7406545542,,false,null,htr23e22-329a-4b05-99c1-606a3ccf6a48,972)
The issue was related to a bug in DirectRunner, when I changed the runner to DataflowRunner the code ran as exepected.
I wanted to use mselec function from drc package for selecting the best model of a dose-response dataset. However, mselect does not work if you use it inside a function.
The following code works:
library(drc)
ryegrass.m1 <- drm(rootl~conc, data = ryegrass, fct = LL.4())
mselect(ryegrass.m1,list(LL.5(), LN.4(), W1.4(), W2.4()))
But not this one:
best.fit=function(data){
model1=drm(rootl~conc, data=data, fct=LL.4())
M1=drc::mselect(model1, list(LL.5(), LN.4(), W1.4(), W2.4()))
return(M1)
}
best.fit(ryegrass)
I think the problem is related with the environments in R, but I don't know how to fix it. Someone could help me please?
I manage to solve the problem like this:
best.fit=function(data){
mf <- match.call(expand.dots = FALSE)
m <- match(c("data"), names(mf), 0L)
data.name=as.character(mf[m])
model1=eval(parse(text=paste0('drm(rootl~conc, data=',data.name, ',fct=LL.4())')))
M1=drc::mselect(model1, list(LL.5(), LN.4(), W1.4(), W2.4()))
return(M1)
}
best.fit(ryegrass)
There should be better ways to do it, but at least it works for me now.
It seems that the update function within mselect doesn't access the original dataframe when run from inside a function. My solution was to add a data argument at line 34.
[1] my_mselect <- function(...
...
[33] tempObj <- try(update(object, fct = fctList[[i]],
[34] data = object$origData), # <--- line added here
[35] silent = TRUE)
I also noticed that the reference to the model variables doens't work either if their relative positions are used instead of their original names, for instance when using drm(data[, 1] ~ data[, 2], fct = LL.4()). To avoid this you can use a temporary dataframe in your function, set the variable names as you want, and use these names in the drm call.
best.fit <- function(data){
tmp_data <- data
names(tmp_data) <- c("Var1", "Var2")
model1 <- drm(Var1 ~ Var2, data = tmp_data, fct = LL.4())
M1 <- my_mselect(model1, list(LL.5(), LN.4(), W1.4(), W2.4()))
return(M1)
}
Is there a way to decode tinyURL links in R so that I can see which web pages they actually refer to?
Below is a quick and dirty solution, but should get the job done:
library(RCurl)
decode.short.url <- function(u) {
x <- try( getURL(u, header = TRUE, nobody = TRUE, followlocation = FALSE) )
if(class(x) == 'try-error') {
return(u)
} else {
x <- strsplit(x, "Location: ")[[1]][2]
return(strsplit(x, "\r")[[1]][1])
}
}
The variable 'u' below contains one shortend url, and one regular url.
u <- c("http://tinyurl.com/adcd", "http://www.google.com")
You can then get the expanded results by doing the following.
sapply(u, decode.short.url)
The above should work for most services which shorten the URL, not just tinyURL. I think.
HTH
Tony Breyal
I don't know R but in general you need to make a http request to the tinyurl-url. You should get back a 301 response with the actual url.
I used Tony Breyal's code, but the function returned NA values for those URLs where there was no URL redirection. Even though Tony listed "google.com" in his example, I think Google redirects you in any case to some sort of localized version of google.com.
Here is how I modified Tony's code to deal with that:
decode.short.url <- function(u) {
x <- try( getURL(u, header = TRUE, nobody = TRUE, followlocation = FALSE) )
if(class(x) == 'try-error') {
print(paste("***", u, "--> ERORR!!!!"))
return(u)
} else {
x <- strsplit(x, "Location: ")[[1]][2]
x.2 <- strsplit(x, "\r")[[1]][1]
if (is.na(x.2)){
print(paste("***", u, "--> No change."))
return(u)
}else{
print(paste("***", x.2, "--> resolved in -->", x.2))
return(x.2)
}
}
}
u <- list("http://www.amazon.com", "http://tinyurl.com/adcd")
urls <- sapply(u, decode.short.url)
library(RCurl)
decode.short.url <- function(u) {
x <- try( getURL(u, header = TRUE, nobody = TRUE, followlocation = FALSE) )
if(class(x) == 'try-error') {
return(u)
} else {
x <- strsplit(x, "Location: ")[[1]][2]
return(strsplit(x, "\r")[[1]][1])
}
}
( u <- c("http://tinyurl.com/adcd", "http://tinyurl.com/fnqsh") )
( sapply(u, decode.short.url) )