gWidgets return multiple responses for multiple columns - arrays

I posted before on this and was not able to arrive at a solution with the single posted response. I have tried another approach that gets me what I want, mostly. The current solution would work better if it were in a single dialogue box but I am not sure how to do this. I am putting together other solutions I found on Nabble and stack and just cannot get what I need. I want the following to offer the choices in a single window, instead of having the user input into 3 separate boxes. Please help.
options(guiToolkit="RGtk2")
library(gWidgets)
#Creat selection function
select <- function(x,multiple = TRUE, Title,...){
ans<-new.env()
x1<-ggroup(horizontal=TRUE) # no parent container here
x2<-gcheckboxgroup( x,multiple=multiple,con=x1,expand=TRUE)
ret <- gbasicdialog(title = Title, widget=x1,handler=function(h,...){
value <- svalue(x2)
if (length(value)==0) value=""
assign("selected",value,env=h$action$env)
dispose(x1)
},action=list(env=ans))
ans
}
#Create list to store results
Days. <- c("Day1","Day2","Day3")
Outputs_ <- list()
SelectionOptions. <- c("Bicycle Event1", "Construction Nearby","Path Closure")
#Cycle through each day
for(day in Days.){
ans <- select(SelectionOptions., Title = day)
Outputs_[[day]] <- ans$selected
}
#return results of selection
unlist(Outputs_)

You are making it a bit more complicated than need be.
you are better off making things asynchronous (in most cases), using a handler to be called when the values are selected.
However, if you want it done this way, make a container for your selection widgets, then add them to the container. This container is then passed into gbasicdialog. That way all will show in one window. Using gWidgets2 makes working with the basic dialog a lot easier.

Okay, here is an example, though I'm not quite sure what problem you are trying to solve, so may be off:
library(gWidgets2)
Days. <- c("Day1","Day2","Day3")
SelectionOptions. <- c("Bicycle Event1", "Construction Nearby","Path Closure")
w <- gwindow()
g <- gformlayout(cont=w)
days <- gradio(Days., cont=g, label="Days:")
opts <- gcombobox(SelectionOptions., cont=g, label="Options:")
btn <- gbutton("Show them", cont=g, label="")
addHandlerClicked(btn, handler=function(h,...) {
values <- lapply(list(days, opts), svalue)
print(values)
})
## or using a modal dialog
dlg <- gbasicdialog(handler=function(h,...) {
values <- lapply(list(days, opts), svalue)
print(values)
})
g <- gformlayout(cont=dlg)
days <- gradio(Days., cont=g, label="Days:")
opts <- gcombobox(SelectionOptions., cont=g, label="Options:")
visible(dlg, TRUE)
## third time is a charm? (Though you could clean this up)
library(gWidgets2)
e <- new.env()
e$Days <- ""; e$Sel <- ""
Days. <- c("Day1","Day2","Day3")
SelectionOptions. <- c("Bicycle Event1", "Construction Nearby","Path Closure")
dlg <- gbasicdialog(title="test", do.buttons=FALSE)
g <- ggroup(cont=dlg, horizontal=FALSE)
fl <- gformlayout(cont=g)
days <- gradio(Days., cont=fl, label="Days:")
cb <- gcombobox(SelectionOptions., selected=0, cont=fl, label="Options:")
handler <- function(h,...) {
e$Days <- svalue(days)
e$Sel <- ifelse(length(svalue(cb)) > 0, svalue(cb), "")
if (all(sapply(e, function(x) nchar(x) > 0)))
dlg$dispose_window()
}
sapply(list(days, cb), addHandlerChanged, handler=handler)
visible(dlg, TRUE)
Take 4
library(gWidgets2)
days <- paste("Day", 1:3)
events <- c("none", "Bicycle Event","Construction Nearby","Path Closure")
l <- list()
handler <- function(h,...) {
l[[h$action]] <<- svalue(h$obj)
if(length(l) == 3)
print(l)
}
w <- gwindow()
g <- gvbox(cont=w)
for (day in days) {
l <- glabel(day, cont=g); font(l) <- list(weight="bold")
gradio(events, cont=g, handler=handler, action=day)
}

Related

Finding the Initial guesses for numerical equations using R

I want a code to find the initial guesses to put into the multiroot function in R, such that the output of the codes,
tr.mean(0.5,5.5,mu5,sigma5)
tr.var(0.5,5.5,mu5, sigma5)
gives 5 and 1 respectively.
Here,
tr.mean<-function(a,b,mu,sigma){
alpha<-(a-mu)/sigma
beta<-(b-mu)/sigma
dalpha<-dnorm(alpha,0,1)
dbeta<-dnorm(beta,0,1)
palpha<-pnorm(alpha,0,1)
pbeta<-pnorm(beta,0,1)
mubar<-mu-sigma*((dbeta-dalpha)/(pbeta-palpha))
mubar
}
tr.var<-function(a,b,mu,sigma){
alpha<-(a-mu)/sigma
beta<-(b-mu)/sigma
dalpha<-dnorm(alpha,0,1)
dbeta<-dnorm(beta,0,1)
palpha<-pnorm(alpha,0,1)
pbeta<-pnorm(beta,0,1)
v1<-(beta*dbeta-alpha*dalpha)/(pbeta-palpha)
v2<-((dbeta-dalpha)/(pbeta-palpha))^2
sigmabar<-(sigma^2)*(1-v1-v2)
sigmabar
}
I want to know a way to get the initial guesses (,) to put in ss5,
model5 <- function(x) c(F1 = 5-tr.mean(0.5,5.5,x[1],x[2]),
F2 = 1-tr.var(0.5,5.5,x[1],x[2]))
ss5 <- multiroot(f = model5, start = c(*,*))
(roots5<-ss5$root)
parameters
(mu5<-roots5[1])
(sigma5<-roots5[2])
validation
tr.mean(0.5,5.5,mu5,sigma5) # this should give 5
tr.var(0.5,5.5,mu5, sigma5) # this should give 1

Lapply function to anova and post hoc test cld

I am new to r and I am trying to get my mind around the apply function. So far I managed to run my anovas for all the the variables on my data and I got the pairwise comparison.
varlist <- names(dt)[5:length(dt)]
# loop
models <- lapply(X = varlist,
FUN = function(t) lm(formula = paste0("`", t, "` ~ block+irrigation*genotype"), data = dt))
#Name the list of models to the column name
names(models) = varlist
## apply anova to each model stored in the list, models
lapply(models, anova)
#marginal-means-all-variable}
res.model1 <- lapply(models, function(x) pairs(emmeans(x, ~genotype:irrigation)))
res.model1
So far so good, now I want to create a compact letter list so I can use to plot it. Previously I used the following but I can't work out how to apply an lapply function to the following code
CLD = cld(res.model1,
alpha=0.05,
Letters=letters,
adjust="tukey")
I use the CLD data to create graphs
I manage to get the letters with the following code but then I am not getting the full anova table.
tx <- with(dt, interaction(irrigation, genotype)) # determining the factors
model2 <- lapply(varlist, function(x) {
lm(substitute(i~block+tx, list(i = as.name(x))), data = dt)}) # using the factors already in "tx"
lapply(model2, anova)
letters = lapply(model2, function(m) HSD.test((m), "tx", alpha = 0.05, group = TRUE, console = TRUE))
Any suggestions to achieve what I need.
Thank you

How do i add blueprint into workflow_set in tidymodels

I tried to follow the examples in the
Link 1 - Sparse Matrix
https://www.tidyverse.org/blog/2020/11/tidymodels-sparse-support/
Link 2 - Workflow_sets
https://www.tmwr.org/workflow-sets.html
I had trouble including the blue print into the workflow sets.
In the examples where workflow_set is defined in link 2
no_pre_proc <-
workflow_set(
preproc = list(simple = model_vars),
models = list(MARS = mars_spec, CART = cart_spec, CART_bagged = bag_cart_spec,
RF = rf_spec, boosting = xgb_spec, Cubist = cubist_spec)
)
and the way we add blue print into the workflow in link 1
wf_sparse <-
workflow() %>%
add_recipe(text_rec, blueprint = sparse_bp) %>%
add_model(lasso_spec)
wf_default <-
workflow() %>%
add_recipe(text_rec) %>%
add_model(lasso_spec)
Where and how do I add the "blueprint = sparse_bp" option in the workflow_set above?
My attempts were
no_pre_proc <-
workflow_set(
preproc = list(simple = model_vars),
models = list(MARS = mars_spec, CART = cart_spec, CART_bagged = bag_cart_spec,
RF = rf_spec, boosting = xgb_spec, Cubist = cubist_spec)) %>%
option_add(update_blueprint(blueprint = sparse_bp))
Running the racing tune gave me this error
Error: Problem with `mutate()` column `option`.
i `option = purrr::map(option, append_options, dots)`.
x All options should be named.
Run `rlang::last_error()` to see where the error occurred
<error/rlang_error>
There were 9 workflows that had no results.
Backtrace:
1. ggplot2::autoplot(...)
2. workflowsets:::autoplot.workflow_set(...)
3. workflowsets:::rank_plot(...)
4. workflowsets:::pick_metric(object, rank_metric, metric)
6. workflowsets:::collect_metrics.workflow_set(x)
7. workflowsets:::check_incompete(x, fail = TRUE)
8. workflowsets:::halt(msg)
Run `rlang::last_trace()` to see the full context.
> rlang::last_trace()
<error/rlang_error>
There were 9 workflows that had no results.
Backtrace:
x
1. +-ggplot2::autoplot(...)
2. \-workflowsets:::autoplot.workflow_set(...)
3. \-workflowsets:::rank_plot(...)
4. \-workflowsets:::pick_metric(object, rank_metric, metric)
5. +-tune::collect_metrics(x)
6. \-workflowsets:::collect_metrics.workflow_set(x)
7. \-workflowsets:::check_incompete(x, fail = TRUE)
8. \-workflowsets:::halt(msg)
>
thanks,
Thank you for asking this question; we definitely are not supporting this use case (passing non-default arguments to the recipe or model) very well right now. We've opened an issue here where you can track our work on this.
In the meantime, you could try a bit of a hacky workaround by manually using update_recipe() on the workflow you are interested in:
library(tidymodels)
#> Registered S3 method overwritten by 'tune':
#> method from
#> required_pkgs.model_spec parsnip
data(parabolic)
set.seed(1)
split <- initial_split(parabolic)
train_set <- training(split)
test_set <- testing(split)
glmnet_spec <-
logistic_reg(penalty = 0.1, mixture = 0) %>%
set_engine("glmnet")
rec <-
recipe(class ~ ., data = train_set) %>%
step_YeoJohnson(all_numeric_predictors())
sparse_bp <- hardhat::default_recipe_blueprint(composition = "dgCMatrix")
wfs_orig <-
workflow_set(
preproc = list(yj = rec,
norm = rec %>% step_normalize(all_numeric_predictors())),
models = list(regularized = glmnet_spec)
)
new_wf <-
wfs_orig %>%
extract_workflow("yj_regularized") %>%
update_recipe(rec, blueprint = sparse_bp)
Created on 2021-12-09 by the reprex package (v2.0.1)
Then (I know this feels hacky for now) manually take this new_wf and stick it in to the wfs_orig$info[[1]]$workflow slot to replace what is there.

eval(parse(text="f")) on shinypass.io

I want to write an app that lets the user enter a function using textInput, and then does something with the function. Here is a toy example:
shinyUI(fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel(
textInput("fun","function:",value="x")
),
mainPanel(
uiOutput("text")
)
)
shinyServer(function(input, output) {
findMax <- reactive({
f <- function(x) eval(parse(text = input$fun), envir = list(x))
x < seq(0,1,length=100)
max(f(x))
})
output$text <- renderText( {
findMax()
})
})
))
and this works just fine when run on my computer locally. But when i submit it to shinyapps.io i get the error: object x not found. It seems there is a problem with the envir argument of eval, but i have not been able to find out what it is.
There is of course a lot of discussion on the eval(parse()) construct in general, so if anyone has a suggestion on how to do this (have the ability to type in an expression in a box and get it turned into a function) differently i would also be grateful.
Wolfgang
After trying a number of things i finally got this one to work:
instead of
f <- function(x) eval(parse(text = input$fun), envir = list(x))
use
eval(parse(text = paste("f <- function(x)",input$fun,sep="")))
i have no idea why both work on my computer locally but only the second works on shinyapps.io . Also, i would still be interested if anyone has a different way to do this.
Wolfgang

Execute Microsoft SQL query on R Shiny

I am writing an R-Shiny app. Can some one tell me how to execute a Microsoft SQL query in R Shiny ?
This is what I have done so far:
data <- reactive({
conn <- reactive ({ databaseOpen(serverName="[serverName]", databaseName=[dbName])})
qr <- reactive ({ SELECT * from myTable })
res <- reactive ({databaseQuery(conn = conn,query = qr)})
close(conn)
View(res)
})
Any help is appreciated !
I was able to call a query by creating a function outside of the server and ui functions (in other words, in a global.r). Then the server function could call that query function using one of the inputs in the function.
Here is my code:
queryfunction <- function(zipper){
odbcChannel <- odbcConnect("myconnection")
querydoc <- paste0("
SELECT distinct *
FROM mydb
where substring(nppes_provider_zip,1,2) = '43'
and [provider_type] = 'General Practice'
")
pricetable <- sqlQuery(odbcChannel, querydoc)
close(odbcChannel)
pricetable[which(substring(pricetable$nppes_provider_zip,1,5)==zipper),]
}
server <- shinyServer(function(input, output) {
output$mytable1 <- renderDataTable(data.table(queryfunction(input$zip)))
})
I figured it out. It can be done as:
server.r
serverfun<-function(input, output){
# Storing values in myData variable
myData <- reactive({
# Opening database connection
conn <- databaseOpen(serverName = "myServer",databaseName = "myDB")
# Sample query which uses some input
qr <- paste( "SELECT name FROM Genes g WHERE Id = ",input$myId," ORDER BY name")
# Storing results
res <- databaseQuery(conn = conn,query = qr)
# closing database
databaseClose(conn)
# Returning results
res
})
output$tbTable <- renderTable({
# Checking if myData is not null
if(is.null(myData())){return ()}
# return myData
myData()
})
ui.r
library("shiny")
shinyUI(
pageWithSidebar(
headerPanel("Hide Side Bar example"),
sidebarPanel(
textInput("Id", "Enter ID below","1234")
),
mainPanel(
tabsetPanel(
tabPanel("Data", tableOutput("tbTable"))
)
)
)
)

Resources