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
Related
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 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)
I'm testing modulization for an shiny app. One problem in the following code is that, when select a new name under "name to analyze", updated result does not hold. The selection will automatically return to 'name1' within seconds. Much appreciated for any advice to correct it.
Thanks.
library(shiny)
subgroupInput <- function(id){
ns <-NS(id)
tagList(
selectInput(ns("name"),
label = "name to analyze",
choices = NULL,selected=NULL),
radioButtons(ns('radio'), 'cutoffType', choices=c('percentile', 'value'),
selected = NULL, inline = FALSE),
conditionalPanel(
condition = paste0("input['", ns("radio"), "'] == 'percentile'"),
sliderInput(ns("cutoff1"),
label = "Bottom-trim percentile:",
min = 0, max = 100, value = 5),
sliderInput(ns("cutoff2"),
label = "Top-trim percentile:",
min = 0, max = 100, value = 95)
),
conditionalPanel(
condition = paste0("input['", ns("radio"), "'] == 'value'"),
sliderInput(ns("cutoff3"),
label = "Bottom-trim value:",
min = 0, max = 100, value = -1),
sliderInput(ns("cutoff4"),
label = "Top-trim value:",
min = 0, max = 100, value = 1)
)
)
}
subgroup <- function(input, output, session,default_selected=NULL){
ns=session$ns
model <- reactive({
data = data.frame(matrix(rep(rnorm(100*100,sd=3)),ncol=100),stringsAsFactors = F)
colnames(data)=paste0('name',1:100)
namelist = colnames(data)
updateSelectInput(session, "name",choices = namelist, selected = default_selected)
validate(
shiny::need(input$name,"Select name")
)
x = round(data[,input$name])
updateSliderInput(session, "cutoff3", label="Cufoff value", min=min(x),max=max(x))
updateSliderInput(session, "cutoff4", label="Cufoff value", min=min(x),max=max(x))
if(input$radio=="percentile") {
dt = data[,input$name]
qt = quantile(dt,c(input$cutoff1,input$cutoff2)/100)
result <- hist(dt[dt>qt[1] & dt<=qt[2]],main=paste0("Histogram of ",input$name))
}
else if(input$radio=="value"){
dt = data[,input$name]
result <- hist(dt[dt>input$cutoff3 & dt<=input$cutoff4],main=paste0("Histogram of ",input$name))
}
return(list(plot = result, data = data, inname=input$name))
})
return (model)
}
The above are modules. Following code makes call:
shinyApp(
ui = fluidPage(
subgroupInput("test1"),
plotOutput("plot")
),
server = function(input, output, session){
test <- shiny::callModule(subgroup,"test1")
output$plot <- renderPlot({
test()$plot
})
}
)
I am using Shiny R, but I do not know to solve a problem in server. The "climate2" and "weather10" objects were not found. Likely, the "latlong" and "comp" objects show problems, but I do not know. The "latlong" argument of "forecast10day" function does not work with my "latlong" object and the "semi_join" function does not work with my "comp" object. I am copying only a part of the code because it is very long.
Many thanks!
Global R.
# Climate
climate <- cbind(tmin,tmax[,-c(1:3)],rhpm[,-c(1:3)],rham[,-c(1:3)])
names(climate) <- c("Long","Lat","Month","Tmin","Tmax","RHmin","RHmax")
head(climate,2)
Server:
latlong <- reactive({
latlong <- as.character(c(input$Lat,input$Long))
weather.10 <- forecast10day(set_location(lat_long = paste(latlong,collapse = ",")))
names(weather.10)[names(weather.10) == "temp_high"] <- "Tmax"
names(weather.10)[names(weather.10) == "temp_low"] <- "Tmin"
weather.10$Tmax <- fahrenheit.to.celsius(weather.10$Tmax, round = 0)
weather.10$Tmin <- fahrenheit.to.celsius(weather.10$Tmin, round = 0)
})
#Outputs
output$text0 <- renderText({
if(input$Irrigation =="No")
if(round(mean(min(weather.10$Tmin))) > 17 && round(mean(max(weather.10$Tmax))) < 35 && round(mean(min(weather.10$ave_humidity))) > 34 && round(mean(max(weather.10$ave_humidity))) < 87)
{
paste("The combination Biological and Chemical control is recomended in Drought or Rainy period.")
}else{
paste("Biological or chemical control or both may be inefficient and there are low risk of epidemics")
}
})
comp <- reactive ({
#Selecting options of user
comp <- data.frame(input$Long, input$Lat,input$Month)
climate <- semi_join(climate, comp, by=c("Long","Lat","Month"))
climate2 <- data.frame(unique(climate$Long),unique(climate$Lat),unique(climate$Month),round(mean(climate$Tmin)),
round(mean(climate$Tmax)),round(mean(climate$RHmin)),
round(mean(climate$RHmax)))
names(climate2) <- c("Long", "Lat","Mont","Tmin","Tmax","RHmin","RHmax")
})
output$text1 <- renderText({
if(input$Irrigation =="50-60%")
if(climate2$Tmax > 17 && climate2$Tmin < 35 && climate2$RHmin > 34 && climate2$RHmax < 87)
{
paste("The combination Biological and Chemical control is recomended.")
}else{
paste("Biological or chemical control or both may be inefficient. You can see more information in FORECASTING.")
}
})
This is my UI.
ui <- fluidPage(theme = shinytheme("superhero"),
h3("Information system to control Dry Root Rot in Common Beans"),
sidebarLayout(sidebarPanel(
numericInput("Long", label = h3("Longitude:"), value = -49),
numericInput("Lat", label = h3("Latitude:"), value = -17),
actionButton("recalc", "Show point"),
selectInput(inputId = "Irrigation",label = "Irrigation (Soil Available Water)",
choices = c("No","50-60%","80-90%","110-120%","140-150%"),
selected = "80-90%"
),
selectInput(inputId = "Month", label = "Current Month", choices = c("Jan","Feb","March","April","May","June","July",
"Aug","Sep","Oct","Nov","Dec")),
So I am trying to draw a few ggplots and their legend using gridExtra. The legend appears in the last cell on a white background - I would like to change the background color there, so that white background disappears. How can I do that?
Here's my code:
library(reshape)
library(ggplot2)
library(plyr)
library(wq)
library(gridExtra)
library(lattice)
library(grid)
testVisualization <- function()
{
set.seed(123)
xx <- sample(seq(from = 20, to = 50, by = 5), size = 50, replace = TRUE)
yy <- sample(seq(from = 1, to = 50), size = 50, replace = TRUE)
zz <- sample(seq(from = 1, to = 10, by = 1), size = 50, replace = TRUE)
dd <- data.frame(xx,yy,zz)
colRainbow <- rainbow(n, s = 1, v = 1, start = 0, end = max(1, n - 1)/n, alpha = 1)
gg <- ggplot() + geom_point(data=dd, aes(x=xx, y=yy, colour=zz))+
theme_custom()
lay2 <- rbind(c(1,1,1,1,1),
c(2,2,3,3,4))
legg1 <- g_legend(gg)
grid.arrange(
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
legg1,
layout_matrix=lay2)
}
theme_custom <- function()
{
theme(
plot.background = element_rect(fill = "#002B36", colour = "#002B36"),
panel.background = element_rect(fill = "#002B36"),
panel.background = element_rect(fill = "#002B36"),
legend.background = element_rect(fill="#002B36", colour = "#002B36"),
legend.margin = unit(c(-4, -4), "cm"),
legend.key = element_rect(fill="#002B36", colour ="#002B36"),
legend.text =element_text(colour = "#DCD427"),
legend.title=element_text(colour = "#DCD427")
)
}
g_legend<-function(a.gplot){
tmp <- ggplot_gtable(ggplot_build(a.gplot))
leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
legend <- tmp$grobs[[leg]]
#+ legend.margin = unit(-0.5, "cm")
legend
}
Try this,
g_legend<-function(gg){
tmp <- ggplot_gtable(ggplot_build(gg))
id <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
leg <- tmp$grobs[[id]]
bkg <- leg[["grobs"]][[1]][["grobs"]][leg[["grobs"]][[1]][["layout"]][,"name"]=="background"][[1]][["gp"]][["fill"]]
leg <- gtable_add_grob(leg, grobs = rectGrob(gp=gpar(fill=bkg, col="red", lty=2)),
t=1, l=1, b=nrow(leg), r=ncol(leg), z=-1)
# no idea why, but the legend seems to have weird negative sizes
# that make the background overlap with neighbouring elements
# workaround: set those unidentified sizes to 1null
leg$widths[c(1,2,4,5)] <- unit(rep(1,4),"null")
leg$heights[c(1,2,4,5)] <- unit(rep(1,4),"null")
leg
}