How to download Rhandsontable output into .xlsx and .pdf? - pdf

I would like to download rhandsontable output object from an R Shiny app into .xlsx and .pdf format. Does anyone have any idea how to do this? For example, I want to download the tables in the results tab in the app below (the codes are copied from my other question earlier):
library(shiny)
library(rhandsontable)
ui <- navbarPage("App",
tabPanel("Input",
numericInput('num_of_table', "Number of sub tabs: ", value = 1, min = 1, max = 10),
uiOutput("input")),
tabPanel("Results",
uiOutput("results"))
)
server <- function(input, output,session) {
### Input ###
input_table <- reactive({
list_of_input_table = list()
for (i in c(1:input$num_of_table)){
mat <- matrix(c(1:25) * i, ncol = 5, nrow = 5)
list_of_input_table[[i]] = as.data.frame(mat)
}
index = c(1:i)
list_of_input_table[index]
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('input_table_', i)]] <- renderRHandsontable({
rhandsontable(input_table()[[i]])
})
})
})
output$input <- renderUI({
nTabs = input$num_of_table
myTabs1 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("input_table_", x))))
})
do.call(tabsetPanel, myTabs1)
})
### Results ###
results_table <- reactive({
list_of_results_table = list()
for (i in c(1:input$num_of_table)){
req(input[[paste0("input_table_", i)]])
list_of_results_table[[i]] <- hot_to_r(input[[paste0("input_table_", i)]])[2:5]/hot_to_r(input[[paste0("input_table_", i)]])[1:4]
}
return(list_of_results_table)
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('results_table_', i)]] <- renderRHandsontable({
rhandsontable(results_table()[[i]])
})
})
})
output$results <- renderUI({
nTabs = input$num_of_table
myTabs2 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("results_table_", x))))
})
do.call(tabsetPanel, myTabs2)
})
}
shinyApp(ui,server)
Appreciate any help! Thanks!

This will download the results but you will need to first click all the tabs in the results to essentially have the results rhandsontables active and then hit the downloadButton which you can also change to a downloadLink().
library(shiny)
library(rhandsontable)
library(writexl)
ui <- navbarPage("App",
tabPanel("Input",
numericInput('num_of_table', "Number of sub tabs: ", value = 1, min = 1, max = 10),
uiOutput("input")
),
tabPanel("Results",
downloadButton("dwnld", "Download Results"),
uiOutput("results"))
)
server <- function(input, output,session) {
### Input ###
input_table <- reactive({
list_of_input_table = list()
for (i in c(1:input$num_of_table)){
mat <- matrix(c(1:25) * i, ncol = 5, nrow = 5)
list_of_input_table[[i]] = as.data.frame(mat)
}
index = c(1:i)
list_of_input_table[index]
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('input_table_', i)]] <- renderRHandsontable({
rhandsontable(input_table()[[i]])
})
})
})
output$input <- renderUI({
nTabs = input$num_of_table
myTabs1 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("input_table_", x))))
})
do.call(tabsetPanel, myTabs1)
})
### Results ###
results_table <- reactive({
list_of_results_table = list()
for (i in c(1:input$num_of_table)){
req(input[[paste0("input_table_", i)]])
list_of_results_table[[i]] <- hot_to_r(input[[paste0("input_table_", i)]])[2:5]/hot_to_r(input[[paste0("input_table_", i)]])[1:4]
}
return(list_of_results_table)
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('results_table_', i)]] <- renderRHandsontable({
rhandsontable(results_table()[[i]])
})
})
})
output$results <- renderUI({
nTabs = input$num_of_table
myTabs2 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("results_table_", x))))
})
do.call(tabsetPanel, myTabs2)
})
output$dwnld <- downloadHandler(
filename = function(){ paste0("results.xlsx")},
content = function(file){
resultslist <- lapply(1:input$num_of_table, function(x) hot_to_r(input[[paste0("results_table_",x)]]))
write_xlsx(resultslist, path = file)
}
)
}
shinyApp(ui,server)

Related

Shiny app with dynamic bs_accordion_sidebar() using insertUI

I am trying to build a dynamic Shiny app that insert sliders in a bs_accordion_sidebar.
The "add" button is working well but I can't figure out what I should add in my "delete" button code to update the barplot ?
Also, when clicking on the panel title, I think it should collapse and change his color but nothing happen ?
Thanks for any help !
library(shiny)
library(bsplus)
# global button counter
cpt <- 0
# function to create a new slider input
newinput <- function(ID, tag){
div(id=ID,
bs_append(
tag = tag,
title_side = ID,
content_side = NULL,
content_main = sliderInput( inputId = paste0("slider_",ID),
label = paste0("slider_",ID),
value = 0,
min=0,
max=10)
)
)
}
# UI
ui <- shinyUI(fluidPage(
titlePanel("bs_append and insertUI"),
sidebarPanel(
fluidRow(
actionButton("add", "+"),
mytag <- bs_accordion_sidebar(id = "accordion",
spec_side = c(width = 4, offset = 0),
spec_main = c(width = 8, offset = 0)),
div(id = "placeholder"),
actionButton("delete", "-")
)
),
mainPanel(
plotOutput('show_inputs')
),
use_bs_accordion_sidebar()
))
# SERVER
server <- shinyServer(function(input, output) {
# reactive function to collect all input values
AllInputs <- reactive({
myvalues <- sapply(names(input)[!names(input) %in% c("add", "delete")], function(x) input[[x]])
print(myvalues)
return(myvalues)
})
# simple output barplot
output$show_inputs <- renderPlot({
barplot(AllInputs())
})
# take a dependency on 'add' button
observeEvent(input$add, {
cpt <<- cpt + 1
insertUI(
selector ='#placeholder',
where = "beforeEnd",
ui = newinput(ID = cpt,
tag = mytag)
)
})
# take a dependency on 'delete' button
observeEvent(input$delete, {
removeUI(selector = paste0('#', cpt))
cpt <<- cpt - 1
})
})
shinyApp(ui, server)
I have found the answer here : https://stackoverflow.com/a/51517902/12812645
it was necessary to nullify the input deleted by removeUI
here is the corrected code using shinyjs :
library(shiny)
library(bsplus)
library(shinyjs)
# global button counter
cpt <- 0
# function to create a new slider input
newinput <- function(ID, tag){
div(id=ID,
bs_append(
tag = tag,
title_side = ID,
content_side = NULL,
content_main = sliderInput( inputId = paste0("slider_",ID),
label = paste0("slider_",ID),
value = 0,
min=0,
max=10)
)
)
}
# UI
ui <- shinyUI(fluidPage(
titlePanel("bs_append and insertUI"),
sidebarPanel(
fluidRow(
actionButton("add", "+"),
mytag <- bs_accordion_sidebar(id = "accordion",
spec_side = c(width = 4, offset = 0),
spec_main = c(width = 8, offset = 0)),
div(id = "placeholder"),
actionButton("delete", "-")
)
),
mainPanel(
plotOutput('show_inputs')
),
useShinyjs(debug = TRUE),
use_bs_accordion_sidebar()
))
# SERVER
server <- shinyServer(function(input, output) {
# reactive function to collect all input values
AllInputs <- reactive({
myvalues <- sapply(names(input)[!names(input) %in% c("add", "delete")], function(x) input[[x]])
myvalues <- unlist(myvalues[!unlist(lapply(myvalues, is.null))])
print(myvalues)
return(myvalues)
})
# simple output barplot
output$show_inputs <- renderPlot({
barplot(AllInputs())
})
# take a dependency on 'add' button
observeEvent(input$add, {
cpt <<- cpt + 1
insertUI(
selector ='#placeholder',
where = "beforeEnd",
ui = newinput(ID = cpt,
tag = mytag)
)
})
# take a dependency on 'delete' button
observeEvent(input$delete, {
removeUI(selector = paste0('#', cpt))
runjs(paste0('Shiny.onInputChange("slider_',cpt,'", null)'))
cpt <<- cpt - 1
})
})
shinyApp(ui, server)

How to get/set weights for a supervised model in tensorflow.js?

I'd like to change the weights of a supervised model but I get the same exact result after changing the weights. What am I doing wrong?
const model = tf.sequential();
model.add(tf.layers.dense({...}));
model.add(tf.layers.dense({...}));
model.add(tf.layers.dense({...}));
model.compile({...});
model.fit({});
const result1 = model.predict(tf.tensor2d(...)).dataSync();
const newWeights = [];
model.layers.map((layer, i) => {
newWeights[i] = []
const weights = layer.getWeights();
newWeights[i][0] = weights[0].arraySync()
newWeights[i][1] = weights[1].arraySync()
newWeights[i][0].map(tensor => tensor.map(x => {
if (random(1) < 0.5) {
return x + offset();
}
return x;
})
layer.setWeights([tf.tensor2d(newWeights[i][0], [newWeights[i][0].length, newWeights[i][0][0].length]), tf.tensor(newWeights[i][1])])
})
const result2 = model.predict(tf.tensor2d(...)).dataSync();
Code snippets:
const random = (max) => {
return floor(Math.random() * Math.floor(max), 2);
}
const floor = (num, toDecimal) => {
let dec = Math.pow(10, toDecimal);
return Number(Math.floor(num * dec) / dec);
}
const offset = () => {
randomGaussian() * 0.5
}
let previous = false;
let y2 = 0;
const randomGaussian = (mean, sd) => {
let y1, x1, x2, w;
if (previous) {
y1 = y2;
previous = false;
} else {
do {
x1 = random(2) - 1;
x2 = random(2) - 1;
w = x1 * x1 + x2 * x2;
} while (w >= 1);
w = Math.sqrt(-2 * Math.log(w) / w);
y1 = x1 * w;
y2 = x2 * w;
previous = true;
}
let m = mean || 0;
let s = sd || 1;
return y1 * s + m;
};
result1 === result2 but why?
Most likely that the new weights are identical to that of the first model.
Example: Simple example to change weights of a model
(async() => {
const model = tf.sequential({
layers: [tf.layers.dense({units: 1, inputShape: [10]})]
});
model.compile({optimizer: 'sgd', loss: 'meanSquaredError'});
for (let i = 1; i < 5 ; ++i) {
const h = await model.fit(tf.ones([8, 10]), tf.ones([8, 1]), {
batchSize: 4,
epochs: 3
});
console.log("Loss after Epoch " + i + " : " + h.history.loss[0]);
}
const p = await model.predict(tf.zeros([1, 10]))
p.print()
const layers = model.layers
layers[0].setWeights([tf.zeros([10, 1]), tf.zeros([1])])
const q = await model.predict(tf.zeros([1, 10]))
q.print()
})()
<html>
<head>
<!-- Load TensorFlow.js -->
<script src="https://cdn.jsdelivr.net/npm/#tensorflow/tfjs#latest"> </script>
</head>
<body>
</body>
</html>
Issue of the code
The newWeights created is not assigned to newWeights. map is not an in-place operator. The array returned by map should be assigned back to newWeights.
newWeights[i][0] = newWeights[i][0].map(tensor => tensor.map(x => {
if (random(1) < 0.5) {
return x + offset();
}
return x;
})

How can I build a table result with "eventReactive" in shiny

How can I create a "table result" to each relationship I assumed in the selectInput "Col" and "Row"? Dinamicaly, after each press 'ok' botom.
library(shiny)
shinyUI(fluidPage(
h4("Give a valor between 0 to 5, to each col/row relationship"),
uiOutput("colrow"),
hr(),
h5("Result:"),
tableOutput("result")
))
shinyServer(
function(input, output, session) {
cols <<- c("Select"="", "col01" = "c01", "col02" = "c02")
rows <<- c("Select"="", "row01" = "r01", "row02" = "r02")
values <<- c("Select"="", 1:5)
output$colrow <- renderUI({
div(selectInput("ipt_col", label = "Col",
choices = c(cols),
selected = cols[1],
width = "50%"),
selectInput("ipt_row", label = "Row",
choices = c(rows),
selected = rows[1],
width = "50%"),
selectInput("ipt_vlr", label = "Value",
choices = c(values),
selected = ""),
actionButton("bt_ok", "ok")
)
})
colrow_vlr <- eventReactive(input$bt_ok, {
as.data.frame(matrix(input$ipt_vlr, 1,1, dimnames = list(input$ipt_row,input$ipt_col)))
})
output$result <- renderTable({
colrow_vlr()
})
})
I changed your code a little bit and now it works. I added comments at where the changes were made.
library(shiny)
ui <- fluidPage(
h4("Give a valor between 0 to 5, to each col/row relationship"),
uiOutput("colrow"),
hr(),
h5("Result:"),
# using DT which is recommended in shiny
DT::dataTableOutput("result")
)
server <- function(input, output, session) {
# no need to assign in the global env especially 'cols' is reserved
cols <- c("Select"="", "col01" = "c01", "col02" = "c02")
rows <- c("Select"="", "row01" = "r01", "row02" = "r02")
values <- c("Select"="", 1:5)
output$colrow <- renderUI({
div(selectInput("ipt_col", label = "Col",
choices = cols, # no need to wrap with c()
selected = cols[1],
width = "50%"),
selectInput("ipt_row", label = "Row",
choices = rows,
selected = rows[1],
width = "50%"),
selectInput("ipt_vlr", label = "Value",
choices = values,
selected = ""),
actionButton("bt_ok", "ok")
)
})
colrow_vlr <- eventReactive(input$bt_ok, {
as.data.frame(matrix(input$ipt_vlr, 1,1, dimnames = list(input$ipt_row,input$ipt_col)))
})
output$result <- DT::renderDataTable({
colrow_vlr()
})
}
shinyApp(ui = ui, server = server)

How to remove scientific notation for Rplot chart

I developed this R-script to drive a decision flow Rplot chart, but I can't get it to show numeric values instead of scientific notation. I spent half of the work day yesterday trying to make it numeric by following examples I found on stackoverflow, but so far no luck. See code and screenshot for details.
#automatically convert columns with few unique values to factors
convertCol2factors<-function(data, minCount = 3)
{
for (c in 1:ncol(data))
if(is.logical(data[, c])){
data[, c] = as.factor(data[, c])
}else{
uc<-unique(data[, c])
if(length(uc) <= minCount)
data[, c] = as.factor(data[, c])
}
return(data)
}
#compute root node error
rootNodeError<-function(labels)
{
ul<-unique(labels)
g<-NULL
for (u in ul) g = c(g, sum(labels == u))
return(1-max(g)/length(labels))
}
# this function is almost identical to fancyRpartPlot{rattle}
# it is duplicated here because the call for library(rattle) may trigger GTK load,
# which may be missing on user's machine
replaceFancyRpartPlot<-function (model, main = "", sub = "", palettes, ...)
{
num.classes <- length(attr(model, "ylevels"))
default.palettes <- c("Greens", "Blues", "Oranges", "Purples",
"Reds", "Greys")
if (missing(palettes))
palettes <- default.palettes
missed <- setdiff(1:6, seq(length(palettes)))
palettes <- c(palettes, default.palettes[missed])
numpals <- 6
palsize <- 5
pals <- c(RColorBrewer::brewer.pal(9, palettes[1])[1:5],
RColorBrewer::brewer.pal(9, palettes[2])[1:5], RColorBrewer::brewer.pal(9,
palettes[3])[1:5], RColorBrewer::brewer.pal(9, palettes[4])[1:5],
RColorBrewer::brewer.pal(9, palettes[5])[1:5], RColorBrewer::brewer.pal(9,
palettes[6])[1:5])
if (model$method == "class") {
yval2per <- -(1:num.classes) - 1
per <- apply(model$frame$yval2[, yval2per], 1, function(x) x[1 +
x[1]])
}
else {
per <- model$frame$yval/max(model$frame$yval)
}
per <- as.numeric(per)
if (model$method == "class")
col.index <- ((palsize * (model$frame$yval - 1) + trunc(pmin(1 +
(per * palsize), palsize)))%%(numpals * palsize))
else col.index <- round(per * (palsize - 1)) + 1
col.index <- abs(col.index)
if (model$method == "class")
extra <- 104
else extra <- 101
rpart.plot::prp(model, type = 2, extra = extra, box.col = pals[col.index],
nn = TRUE, varlen = 0, faclen = 0, shadow.col = "grey",
fallen.leaves = TRUE, branch.lty = 3, ...)
title(main = main, sub = sub)
}
###############Upfront input correctness validations (where possible)#################
pbiWarning<-""
pbiInfo<-""
dataset <- dataset[complete.cases(dataset[, 1]), ] #remove rows with corrupted labels
dataset = convertCol2factors(dataset)
nr <- nrow( dataset )
nc <- ncol( dataset )
nl <- length( unique(dataset[, 1]))
goodDim <- (nr >=minRows && nc >= 2 && nl >= 2)
##############Main Visualization script###########
set.seed(randSeed)
opt = NULL
dtree = NULL
if(autoXval)
xval<-autoXvalFunc(nr)
dNames <- names(dataset)
X <- as.vector(dNames[-1])
form <- as.formula(paste('`', dNames[1], '`', "~ .", sep = ""))
# Run the model
if(goodDim)
{
for(a in 1:maxNumAttempts)
{
dtree <- rpart(form, dataset, control = rpart.control(minbucket = minBucket, cp = complexity, maxdepth = maxDepth, xval = xval)) #large tree
rooNodeErr <- rootNodeError(dataset[, 1])
opt <- optimalCPbyXError(as.data.frame(dtree$cptable))
dtree<-prune(dtree, cp = opt$CP)
if(opt$ind > 1)
break;
}
}
#info for classifier
if( showInfo && !is.null(dtree) && dtree$method == 'class')
pbiInfo <- paste("Rel error = ", d2form(opt$relErr * rooNodeErr),
"; CVal error = ", d2form(opt$xerror * rooNodeErr),
"; Root error = ", d2form(rooNodeErr),
";cp = ", d2form(opt$CP, 3), sep = "")
if(goodDim && opt$ind>1)
{
#fancyRpartPlot(dtree, sub = pbiInfo)
replaceFancyRpartPlot(dtree, sub = pbiInfo)
}else{
if( showWarnings )
pbiWarning <- ifelse(goodDim, paste("The tree depth is zero. Root error = ", d2form(rooNodeErr), sep = ""),
"Wrong data dimensionality" )
plot.new()
title( main = NULL, sub = pbiWarning, outer = FALSE, col.sub = "gray40" )
}
remove("dataset")
Also, how can I tell what "n" means from the photo below? (I copied this code from a project).
Try adding digits = -2 to the prp call in your code

Shiny + GGplot - mouse click coordinates

I have a doubt in shiny ploting a GGPlot Bar Graph.
I can recognize coordinates of mouse click (x,y), but I need know a value of bar (x-axis) to refresh the graph with parameter and simulate a drill-down.
Anyone can help me?
library(shiny)
library(ggplot2)
ui <- fluidPage(
plotOutput("plot", click = "GGPlot_click")
)
server <- function(input, output, session) {
v <- reactiveValues(
click1 = NULL
)
# Handle clicks on the plot
observeEvent(input$GGPlot_click, {
v$click1 <- input$GGPlot_click
})
observeEvent(input$reset, {
v$click1 <- NULL
})
output$plot <- renderPlot({
pg <- ggplot(cars, aes(speed, dist)) + geom_bar(stat="identity")
print(pg)
if (!is.null(v$click1$x))
print(paste(v$click1$x, v$click1$y, sep = " / "))
#print(v$click1)
})
}
shinyApp(ui, server)
images and code: https://github.com/faustobranco/stackquestion
I find a way to resolve:
imagens and codes: https://github.com/faustobranco/StackQuestions
library(shiny)
library(ggplot2)
ui <- fluidPage(
plotOutput("plot", click = "plot_click"),
verbatimTextOutput("info")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(cars, aes(speed, dist)) + geom_bar(stat="identity")
})
output$info <- renderText({
xy_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("x=", round(e$x, 1), "\n")
}
x_Numeric <- function(e) {
if(is.null(e)) return(0)
round(e$x, 1)
}
paste0(
"click: x = ", xy_str(input$plot_click),
"Nearest x-axis[?]: ", toString(which(abs(as.numeric(cars$speed)-as.numeric(x_Numeric(input$plot_click)))==min(abs(as.numeric(cars$speed)-as.numeric(x_Numeric(input$plot_click))))))
)
})
}
shinyApp(ui, server)