Eingabe in eine benutzerdefinierte Funktion für eine glänzende App. R

Question

Hallo ich versuche, eine App in glänzend zu machen, die 3 Vektoren aus einem Datenrahmen und zwei eingegebenen Eingaben nehmen wird. Ich möchte, dass die fünf Einträge die Funktion übergeben, die ich Magd unten habe und geben Sie die Ausgabe, dass die Funktion Magd zu geben ist. Dies wären 4 Plots in einem Raster (zwei Heatmaps, ein Punktplot und ein Simivariogramm). Ich habe das Gefühl, dass ich den Großteil der App zusammen habe, aber ich habe Schwierigkeiten, meine fünf Eingaben von der UI zu bekommen, um meine Funktion zu übergeben und die Plots zu verteilen. Die Funktion funktioniert hervorragend in R ohne Glanz, ich möchte nur, dass sie jetzt als App funktioniert. Auch ich bin ziemlich neu zu glänzend, so dass ich etwas Einfaches vermissen könnte.

UI:

library(shiny) 
    library(shinydashboard) 
    library(ggplot2) 
    library(leaflet) 
    library(data.table) 
    library(dplyr) 

    ################ 

# App interface 
ui <- fluidPage(
# App csv input 
    headerPanel("Kriging"), 
    sidebarPanel(
    fileInput('file1', 'Choose CSV File', 
       accept=c('text/csv','text/comma-separated-values,text/plain','.csv')), 
    tags$hr(), 
    checkboxInput('header', 'Header', TRUE), 
# App button selection for var, lat, lon 
    fluidRow(
     column(6,radioButtons("xaxisGrp","Var:", c("1"="1","2"="2"))), 
     column(6,checkboxGroupInput("yaxisGrp","Lat/Lon:", c("1"="1","2"="2"))) 
    ), 
# App buttons comma and quote 
    radioButtons('sep', 'Separator', 
       c(Comma=',', Semicolon=';',Tab='\t'), ','), 
    radioButtons('quote', 'Quote', 
       c(None='','Double Quote'='"','Single Quote'="'"),'"'), 
    uiOutput("choose_columns") 
), 
    mainPanel(
    tabsetPanel(
     tabPanel("Plot",plotOutput("plot")), 
     tabPanel("Data", tableOutput('contents')) 
    ) 
) 
# App sliders for values of definition 
    , 
    sliderInput(inputId = "num", 
       label = "choose x", 
       value = 0.1, min = 0.01, max = 1), 
    sliderInput(inputId = "num", 
       label = "choose y", 
       value = 0.1, min = 0.01, max = 1) 

    #initiating kriging 
    , actionButton("btn", "Krige") 
) 



################################################## 

Server: Ich habe meine Funktion boxed weg, aber ich brauche Hilfe meine Argumente in die Funktion übergeben.

server <- function(input, output, session) { 

    dsnames <- c() 

    data_set <- reactive({ 
    inFile <- input$file1 

    if (is.null(inFile)) 
     return() 

    data_set<-read.csv(inFile$datapath, header=input$header, 
         sep=input$sep, quote=input$quote) 
    }) 

    output$contents <- renderTable({data_set()}) 

    #controlling our buttons 
    observe({ 
    dsnames <- names(data_set()) 
    cb_options <- list() 
    cb_options[ dsnames] <- dsnames 
    updateRadioButtons(session, "xaxisGrp", 
         label = "Var", 
         choices = cb_options, 
         selected = "") 
    updateCheckboxGroupInput(session, "yaxisGrp", 
          label = "Lat/Lon", 
          choices = cb_options, 
          selected = "") 
    }) 
    output$choose_dataset <- renderUI({ 
    selectInput("dataset", "Data set", as.list(data_sets)) 
    }) 

    ############################################################## 
    #My function 

    kri <- function(var, lat, lon, defx, defy){ 

    options(warn = -1) 

    #internal function for kriging 
    kri3 <- function(var, lat, lon, defx, defy){ 

     #making a data frame out of the given vector 
     spdf <- data.frame(var,lat,lon) 

     #makeing spatial point data frame coords 
     sp::coordinates(spdf) <- ~ lon + lat 
     bbox <- sp::bbox(spdf) 

     #variogram stuff 
     lzn.vgm <- gstat::variogram(var ~ 1, spdf) 

     lzn.fit1 <- gstat::fit.variogram(lzn.vgm, model = gstat::vgm(1, "Sph", 900, 1)) 

     lzn.fit = automap::autofitVariogram(var ~ 1, 
              spdf, 
              model = c("Sph", "Exp", "Gau", "Ste"), 
              kappa = c(0.05, seq(0.2, 2, 0.1), 5, 10), 
              fix.values = c(NA, NA, NA), 
              start_vals = c(NA,NA,NA), 
              verbose = T) 


     #making our grid 
     cs <- c(defx, defy) 
     bb <- sp::bbox(spdf) 
     cc <- bb[,1] + (cs/2) 
     cd <- ceiling(diff(t(bb))/cs) 
     gold_grd <- sp::GridTopology(cellcentre.offset = cc, cellsize = cs, cells.dim = cd) 
     gold_grd 
     p4s <- sp::CRS(sp::proj4string(spdf)) 
     gold_sg <- sp::SpatialGrid(gold_grd, proj4string = p4s) 
     summary(gold_sg) 

     #kringing and auto kriging 
     lzn.kriged <- as.data.frame(gstat::krige(var ~ 1, spdf, gold_sg , model=lzn.fit1)) 
     lzn.Akriged <- automap::autoKrige(var ~ 1, spdf, gold_sg) 

     lzn.Akriged.pred <- lzn.Akriged$krige_output$var1.pred 
     lzn.Akriged.var <- lzn.Akriged$krige_output$var1.var 

     #making a data frame to use in return 
     kriw <- data.frame(lzn.kriged, lzn.Akriged.var, lzn.Akriged.pred) 
     return(kriw) 
    } 

    kriw <- kri3(var, lat, lon, defx, defy) 

    #internal function for maping 
    Kmap <- function(var, lat, lon, kriw){ 

     #making a data spatial point data frame for out variogram plot 
     spdf <- data.frame(var,lat,lon) 

     #makeing spatial point data frame coords 
     sp::coordinates(spdf) <- ~ lon + lat 
     bbox <- sp::bbox(spdf) 

     #variogram stuff 
     lzn.vgm <- gstat::variogram(var ~ 1, spdf) 

     lzn.fit = automap::autofitVariogram(var ~ 1, 
              spdf, 
              model = c("Sph", "Exp", "Gau", "Ste"), 
              kappa = c(0.05, seq(0.2, 2, 0.1), 5, 10), 
              fix.values = c(NA, NA, NA), 
              start_vals = c(NA,NA,NA), 
              verbose = T) 
     varplot <- plot(lzn.vgm, lzn.fit$var_model, main = "Fitted variogram") 

     #making a dataframe for ggplot 
     kriw <- as.data.frame(kriw) 

     #making a maps 
     bbox1 <- ggmap::make_bbox(lon, lat, f = 1.4) 
     map <- ggmap::get_map(bbox1) 

     #making a heat map 
     M1 <- ggmap::ggmap(map) + 
     ggplot2::geom_tile(data = kriw, ggplot2::aes(x = lon, 
                y = lat, alpha = var1.pred), fill = "red") + ggplot2::ggtitle("Prediction Heat Map") 

     M2 <- ggmap::ggmap(map) + 
     ggplot2::geom_tile(data = kriw, ggplot2::aes(x = lon, 
                y = lat, alpha = var1.var), fill = "red") + ggplot2::ggtitle("Variance Heat Map") 
     var2 <- data.frame(var, lat, lon) 

     Dplot <- ggmap::ggmap(map) + ggplot2::geom_point(data = var2, ggplot2::aes(size=var, color=var, alpha=var)) + 
     ggplot2::coord_equal() + ggplot2::ggtitle("Desnisty map") + ggplot2::theme_bw() 


     #Placing both heat maps together 
     heat <- gridExtra::grid.arrange(M1,M2,varplot,Dplot, ncol=2) 

     return(heat) 

    } 

    #mapping output 
    Kmap(var, lat, lon, kriw) 

    options(warn = 0) 

    } 
############################################### 
# end of my fucntion 


} 

shinyApp(ui = ui, server = server) 

Was ich

Was ich in der Handlung Kasten wünschen

Answer 1

Es scheint, dass Sie eine observe brauchen diese alle zusammen zu binden. Versuchen Sie dies am Ende Ihrer server Funktion.

observeEvent(
    # react to button press 
    input$btn, 
    { 
    # to show the input values 
    str(input$xaxisGrp) 
    str(input$yaxisGrp) 
    # you have defined num for both x and y 
    # so I think you will want to change the 
    # inputId to numX and numY in ui 
    str(input$num) 

    # translate all the inputs into 
    # suitable arguments for kri 

    # send the output from kri 
    output$plot <- renderPlot({ 
     kri(...allyourtranslatedargument...) 
    }) 
    } 
)