Skip to content

Instantly share code, notes, and snippets.

@addame

addame/grts2.R

Forked from jer-shiny/grts2.R
Created January 31, 2014 15:24
Show Gist options
  • Save addame/8734116 to your computer and use it in GitHub Desktop.
Save addame/8734116 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. @jer-shiny jer-shiny revised this gist Jan 30, 2014. 3 changed files with 137 additions and 58 deletions.
    13 changes: 3 additions & 10 deletions instructions.html
    View file
    Original file line number Diff line number Diff line change
    @@ -1,4 +1,4 @@
    <<!DOCTYPE HTML>
    <!DOCTYPE HTML>
    <html>
    <head>
    <title>How to use this page: </title>
    @@ -8,15 +8,8 @@
    </p>
    <p> To use this tool, you will need to provide a polygon dataset in ESRI shapefile format. Upload a .zip file (use window to the left), which contains ALL the files that make up a complete ESRI polygon shapefile, to load your dataset into the tool. </p>
    <p>
    The shapefile must contain a field named <b>strata</b> defining the stratum of the dataset, and this MUST be a text (string) based field.
    The shapefile must contain a field that represents the <b>strata</b> defining the stratum of the dataset, this can be a unique field, if no strata are present in your dataset.
    </p><p>
    This application will display your input polygons in the <b>Plot</b> tab. From there, you can request the number of spatially balanced points you wish to have created, by strata. Oversampled points can also be requested. After selecting 'generate points', the tool will create the points and display them for you, both in the plot, and in table format. Point coordinates in the table are in the same projection as your input dataset.

    AFTER UPLOAD:




    </body>

    </html>
    AFTER UPLOAD:
    129 changes: 100 additions & 29 deletions server.R
    View file
    Original file line number Diff line number Diff line change
    @@ -1,3 +1,4 @@

    library(tools)
    library(shiny)
    library(rgdal)
    @@ -7,19 +8,42 @@ library(latticeExtra)

    source("stratumdesign.R")
    source("grts2.R")

    enable <- function(x) {

    if (inherits(x, 'shiny.tag')) {
    if (x$name %in% c('input', 'select'))
    x$attribs$disabled <-NULL
    x$children <- enable(x$children)

    }
    else if (is.list(x) && length(x) > 0) {
    for (i in 1:length(x))
    x[[i]] <- enable(x[[i]])
    }
    x
    }

    # Define server logic
    shinyServer(function(input, output, session) {

    # allow for wonking big files
    options(shiny.maxRequestSize=30*1024^2)

    observe({
    x <- input$controller
    })

    mySHPdata <- reactive({

    # observe({
    # updateTextInput(session, "strataname", "strata")
    # })

    readSHPdata <- reactive({

    x<- 0
    updateNumericInput(session, "pts", value = x)
    updateNumericInput(session, "oversamppts", value = x)
    enable(updateNumericInput(session, "pts", value = x))
    enable(updateNumericInput(session, "oversamppts", value = x))

    inFile <- input$file1
    if (is.null(inFile))
    return(NULL)
    @@ -35,18 +59,53 @@ shinyServer(function(input, output, session) {
    print(getwd())
    },
    Linux = {
    system(sprintf("unzip -tq %s", inFile$datapath))
    origdir=getwd()
    setwd(dirname(inFile$datapath))
    system(sprintf(" cd %s", dirname(inFile$datapath)))
    print(getwd())
    system(sprintf("unzip -u %s", inFile$datapath))
    setwd(origdir)
    })
    shapename <- list.files(dirname(inFile$datapath), pattern="\\.shp$")
    shapename <- file_path_sans_ext(shapename, compression=FALSE)
    print(shapename)

    require(rgdal)
    return (
    readOGR(dirname(inFile$datapath), shapename)
    )
    })
    theSHP <- readOGR(dirname(inFile$datapath), shapename)

    return (theSHP)
    })

    mySHPdata<-reactive({
    theSHP<-readSHPdata()
    fieldnames<-names(theSHP)
    enable(updateSelectInput(session, "strataname", "select:", c(fieldnames)))
    # now add a stratum field name to have it always the same
    print("WHAT IS THE INPUT STRATA NAME")
    print(input$strataname)
    # first, deal with the strata field if it is numeric by making new column
    if (is.numeric(theSHP$strataname[1])) {
    theSHP$shnystr <- paste(as.character(theSHP$strataname), sep=" ")
    } else {
    #just rename the current text column
    names(theSHP)[names(theSHP)==strataname] <- "shnystr"

    }
    print("OUR STRATUM FIELD CONTAINS : ")
    print(theSHP$shnystr)
    #Diagnostic save
    writeOGR(theSHP, ".", "stratatest", driver="ESRI Shapefile", overwrite_layer=TRUE)

    print(theSHP$shnystr)
    return(theSHP)
    })

    mySHPClass <- reactive ({
    myclass <- class(mySHPdata[])
    print(myclass[1])
    return(myclass[1])
    })

    output$plot <- renderPlot({
    # a variable we can play with, vs the true reactive?
    theSHP<-mySHPdata()
    @@ -60,17 +119,25 @@ shinyServer(function(input, output, session) {
    maxx=limitspoly[3]
    maxy=limitspoly[4]

    #factor strata values
    print(theSHP$n)
    print(theSHP$fid)
    theSHP$n=as.factor(theSHP$n)
    print(limitspoly)



    layer1<-spplot(theSHP, c("n"), xlim=c(minx,maxx), ylim=c(miny,maxy),
    col.regions=brewer.pal(nlevels(theSHP$n), "Accent"))
    if (input$pts >= 1) {
    # if(1==1){
    #factor strata values
    theSHP$shnystr=as.factor(theSHP$shnystr)
    # plotstrata<-as.character(theSHP$shinystrata)

    layer1<-spplot(theSHP, c('shnystr'), xlim=c(minx,maxx), ylim=c(miny,maxy),
    col.regions=brewer.pal(nlevels('shnystr'), "Accent"))

    if (input$pts >= 1) {
    # if(1==1){(
    print("damn you")
    print(theSHP$shnystr)
    layer1<-spplot(theSHP, c(as.character('shnystr')), xlim=c(minx,maxx), ylim=c(miny,maxy),
    col.regions=brewer.pal(nlevels(as.character('shnystr')), "Accent"))
    gimmie<-plotpoints()
    layer2<-spplot(gimmie, c("n"), col.regions="black")
    layer2<-spplot(gimmie, c('stratum'), col.regions="black")
    print(layer1 + layer2)
    }
    else
    @@ -86,9 +153,12 @@ shinyServer(function(input, output, session) {
    theSHP<-mySHPdata()
    if(is.null(theSHP))
    return(NULL)
    print(length(theSHP$strata))
    numstrata<-unique(theSHP$strata)
    print("numstrata is ")

    print(length(theSHP$shnystr))
    numstratavec<-theSHP$shnystr

    numstrata<-unique(numstratavec)
    print("number of strata is ")
    print(numstrata)

    # make dummy first entry for list we will concat to
    @@ -117,14 +187,16 @@ shinyServer(function(input, output, session) {
    save(theSHP, file="shapedata")
    writeOGR(theSHP, ".", "rgdaltest2", driver="ESRI Shapefile", overwrite_layer=TRUE)
    test.attframe<- read.dbf("rgdaltest2")

    grtsstrata <- "shnystr"

    result <- grts2(design=as.list(wholedesign), src.frame="sp.object", sp.object=theSHP, type.frame="area",
    stratum="strata", id="ID",
    stratum=grtsstrata, id="ID",
    att.frame=test.attframe,
    prjfilename="rgdaltest2",
    out.shape="grtstest")
    # x<- 0
    # updateNumericInput(session, "pts", value = x)
    # updateNumericInput(session, "oversamppts", value = x)
    # if stratum are numerics... we need to ensure they are not
    # result$stratum <- as.character(result$stratum)

    save(result, file="result")
    writeOGR(result, ".", "results", driver="ESRI Shapefile", overwrite_layer=TRUE)
    @@ -161,8 +233,11 @@ shinyServer(function(input, output, session) {
    temp2<- temp[,c("siteID", "xcoord", "ycoord", "stratum")]
    })
    plotpoints <- reactive({
    save(grtsPointData, file="grtsPointData")
    return(grtsPointData())



    })

    output$downloadData <- downloadHandler(
    @@ -177,7 +252,3 @@ shinyServer(function(input, output, session) {


    })




    53 changes: 34 additions & 19 deletions ui.R
    View file
    Original file line number Diff line number Diff line change
    @@ -1,26 +1,35 @@
    library(shiny)



    shinyUI(pageWithSidebar(

    # Application title
    headerPanel("Spatially Balanced Sampling Tool"),

    sidebarPanel(
    tags$head(
    tags$style(type="text/css", "select { max-width: 175px; }"),
    tags$style(type="text/css", "textarea { max-width: 150px; }"),
    tags$style(type="text/css", ".jslider { max-width: 150px; }"),
    tags$style(type='text/css', ".well { max-width: 200px; }"),
    tags$style(type='text/css', ".span4 { max-width: 200px; }")
    tags$style(type="text/css", "select { max-width: 250px; }"),
    tags$style(type="text/css", "textarea { max-width: 250px; }"),
    tags$style(type="text/css", ".jslider { max-width: 250px; }"),
    tags$style(type='text/css', ".well { max-width: 250px; }"),
    tags$style(type='text/css', ".span4 { max-width: 250px; }")
    ),

    # conditionalPanel(condition="input.conditionedPanels == 1",
    fileInput('file1', 'Choose .ZIP Shapefile:', multiple=TRUE,
    accept=c('binary'))
    # ),

    # conditionalPanel(condition="input.conditionedPanels >= 2",
    helpText("PLEASE RUN STEPS IN ORDER"),
    helpText(""),

    fileInput('file1', '1) Choose .ZIP Shapefile:', multiple=TRUE,
    accept=c('binary')),
    selectInput("strataname","2) Select a stratum field:", choices=c("strata")),
    helpText("Display now ready in 'Plot' tab..."),

    numericInput("pts", "3) enter # of sampling points per stratum:", 0),
    helpText("And - (optional)"),
    numericInput("oversamppts", "enter # to OVER sample", 0),
    submitButton("Fetch Points!"),
    helpText("Points now ready to view in 'View Points' tab"),
    downloadLink('downloadData', '4) click to Download Points as shapefile')


    ),

    @@ -32,22 +41,28 @@ shinyUI(pageWithSidebar(
    includeHTML("instructions.html"),
    div(id="linkToMap", tags$a("Click here to see a map of your input data and create points")),
    div(id="linkToPoints", tags$a("Click here to see table of created points")),
    value=1
    value=1,
    HTML('<img style="float: right"; src="JornadaLogo_1.png"/>')
    ),

    tabPanel("Plot",
    numericInput("pts", "# of sampling points per stratum:", 0),
    numericInput("oversamppts", "# to OVER sample (optional):", 0),
    submitButton("Generate Points"),

    #
    # conditionalPanel(condition="$('div#plot').hasClass('recalculating'))", h4("Calculating... ")),
    # conditionalPanel(condition="!($('div#grtsPointData').hasClass('recalculating'))", br()),
    # conditionalPanel(condition="$('html').hasClass('shiny-busy')", img(src="dogfetcher2.gif")),
    # conditionalPanel(condition="$('html').hasClass('shiny-busy')", h5("Calculating... ")),
    # conditionalPanel(condition="!($('html').hasClass('shiny-busy'))", br()),


    helpText("Map of input polygons by strata"),
    plotOutput("plot"),
    plotOutput(outputId = "plot"),
    value=2
    ),
    tabPanel("View Points", helpText("suggested sampling points"),
    downloadLink('downloadData', 'Download Points as shapefile'),

    helpText(" "),
    tableOutput("pointdata"),
    tableOutput(outputId = "pointdata"),

    HTML("<script>$('#linkToMap').click(function() {
    tabs = $('.tabbable .nav.nav-tabs li')
  2. @jer-shiny jer-shiny revised this gist Nov 4, 2013. 2 changed files with 4 additions and 2 deletions.
    4 changes: 3 additions & 1 deletion server.R
    View file
    Original file line number Diff line number Diff line change
    @@ -81,6 +81,7 @@ shinyServer(function(input, output, session) {
    grtsPointData <- reactive({
    if(input$pts == 0)
    return(NULL)
    isolate({
    # non-reactive shp we can manipulate
    theSHP<-mySHPdata()
    if(is.null(theSHP))
    @@ -96,7 +97,7 @@ shinyServer(function(input, output, session) {
    print(numstrata[i])

    temp<-list(stratumdesign(numstrata[i],
    isolate(input$pts), isolate(input$oversamppts)))
    input$pts, input$oversamppts))
    names(temp) <- numstrata[i]
    wholedesign<-c(wholedesign, temp)

    @@ -151,6 +152,7 @@ shinyServer(function(input, output, session) {
    allshp<-list.files(pattern="results")
    system(sprintf("zip results %s %s %s", types_as_string))
    })
    })
    return(result)
    })

    2 changes: 1 addition & 1 deletion ui.R
    View file
    Original file line number Diff line number Diff line change
    @@ -39,7 +39,7 @@ shinyUI(pageWithSidebar(
    numericInput("pts", "# of sampling points per stratum:", 0),
    numericInput("oversamppts", "# to OVER sample (optional):", 0),
    submitButton("Generate Points"),

    helpText("Map of input polygons by strata"),
    plotOutput("plot"),
    value=2
  3. @jer-shiny jer-shiny revised this gist Nov 1, 2013. 2 changed files with 780 additions and 0 deletions.
    774 changes: 774 additions & 0 deletions grts2.R
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,774 @@
    grts2<-function (design, DesignID = "Site", SiteBegin = 1, type.frame = "finite",
    src.frame = "shapefile", in.shape = NULL, sp.object = NULL,
    att.frame = NULL, id = NULL, xcoord = NULL, ycoord = NULL,
    stratum = NULL, mdcaty = NULL, startlev = NULL, maxlev = 11,
    maxtry = 1000, shift.grid = TRUE, do.sample = rep(TRUE, length(design)),
    shapefile = TRUE, prjfilename = NULL, out.shape = "sample")
    {
    if (is.null(design))
    stop("\nA design list must be provided.")
    strata.names <- names(design)
    if (is.null(strata.names)) {
    if (length(design) > 1) {
    stop("\nThe design list must be named.")
    }
    else {
    warning("\nSince the single stratum specified in the design list was not named, \n\"None\" will be used for the stratum name.\n")
    strata.names <- "None"
    names(design) <- strata.names
    }
    }
    temp <- match(src.frame, c("shapefile", "sp.object", "att.frame"),
    nomatch = 0)
    if (temp == 0)
    stop(paste("\nThe value provided for argument src.frame, \"",
    src.frame, "\" is not a valid value.", sep = ""))
    sp.ind <- FALSE
    if (src.frame == "sp.object") {
    if (is.null(sp.object))
    stop("\nAn sp package object is required when the value provided for argument src.frame \nequals \"sp.object\".")
    sp.ind <- TRUE
    src.frame <- "shapefile"
    in.shape <- "tempfile0921"
    sp2shape(sp.object, in.shape)
    }
    if (src.frame == "shapefile" && is.null(att.frame))
    att.frame <- read.dbf(in.shape)
    if (src.frame == "att.frame" && type.frame != "finite")
    stop(paste("\nThe value provided for argument type.frame must equal \"finite\" when argument \nsrc.frame equals \"att.frame\" The value provided for argument type.frame was \n\"",
    type.frame, "\".", sep = ""))
    if (is.null(id)) {
    id <- "id"
    att.frame$id <- 1:nrow(att.frame)
    }
    else {
    temp <- match(id, names(att.frame), nomatch = 0)
    if (temp == 0)
    stop(paste("\nThe value provided for the column from att.frame that identifies ID value for \neach element in the frame, \"",
    id, "\", does not occur among the columns in \natt.frame.",
    sep = ""))
    if (length(unique(att.frame[, id])) != nrow(att.frame))
    stop(paste("\nThe ID values for elements of the frame that are provided in att.frame are not \nunique.",
    sep = ""))
    if (src.frame == "att.frame") {
    if (is.factor(att.frame[, id]))
    att.frame[, id] <- as.character(att.frame[, id])
    }
    else {
    if (sp.ind) {
    src.temp <- "sp.object"
    }
    else {
    src.temp <- "shapefile"
    }
    if (!is.numeric(att.frame[, id]))
    stop(paste("\nThe ID values in column \"", id,
    "\" of att.frame must be numeric when argument \nsrc.frame equals \"",
    src.temp, "\".", sep = ""))
    if (any(att.frame[, id] < 1))
    stop(paste("\nThe ID values in column \"", id,
    "\" of att.frame must be positive integers when \nargument src.frame equals \"",
    src.temp, "\".", sep = ""))
    att.temp <- read.dbf(in.shape)
    if (any(att.frame[, id] > nrow(att.temp)))
    stop(paste("\nThe ID values in column \"", id,
    "\" of att.frame must not exceed the number of \nrecords when argument src.frame equals \"",
    src.temp, "\".", sep = ""))
    rm(att.temp)
    if (!is.integer(att.frame[, id]))
    att.frame[, id] <- as.integer(att.frame[, id])
    }
    }
    if (is.null(stratum)) {
    if (length(strata.names) > 1)
    stop("\nThe column from att.frame that identifies stratum membership was not provided \nand design specifies more than one stratum.")
    stratum <- "stratum"
    att.frame$stratum <- factor(rep(strata.names, nrow(att.frame)))
    }
    else {
    temp <- match(stratum, names(att.frame), nomatch = 0)
    if (temp == 0)
    stop(paste("\nThe value provided for the column from att.frame that identifies stratum \nmembership for each element in the frame, \"",
    stratum, "\", does not occur \namong the columns in att.frame.",
    sep = ""))
    }
    if (!is.factor(att.frame[, stratum]))
    att.frame[, stratum] <- as.factor(att.frame[, stratum])
    seltype.ind <- FALSE
    for (s in strata.names) {
    if (design[[s]]$seltype != "Equal") {
    seltype.ind <- TRUE
    }
    }
    if (seltype.ind) {
    if (is.null(mdcaty))
    stop(paste("\nThe name of the column from att.frame that identifies the unequal probability \ncategory for each element in the frame must be provided.",
    sep = ""))
    temp <- match(mdcaty, names(att.frame), nomatch = 0)
    if (temp == 0)
    stop(paste("\nThe value provided for the column from att.frame that identifies the unequal \nprobability category for each element in the frame, \"",
    mdcaty, "\", \ndoes not occur among the columns in att.frame.",
    sep = ""))
    }
    if (!is.null(startlev)) {
    if (startlev < 1)
    stop("\nThe value for startlev cannot be less than 1")
    if (startlev > 11)
    stop("\nThe value for startlev cannot be greater than 11")
    if (maxlev < 1)
    stop("\nThe value for maxlev cannot be less than 1")
    if (maxlev > 11)
    stop("\nThe value for maxlev cannot be greater than 11")
    if (startlev > maxlev)
    stop("\nThe value for startlev cannot be greater than the value for maxlev")
    }
    else {
    if (maxlev < 1)
    stop("\nThe value for maxlev cannot be less than 1")
    if (maxlev > 11)
    stop("\nThe value for maxlev cannot be greater than 11")
    }
    if (type.frame == "finite") {
    first <- TRUE
    SiteBegin <- SiteBegin
    if (src.frame == "shapefile") {
    temp <- .Call("readShapeFilePts", in.shape)
    xcoord <- "x"
    ycoord <- "y"
    att.frame$x <- temp$x[att.frame[, id]]
    att.frame$y <- temp$y[att.frame[, id]]
    }
    else if (src.frame == "att.frame") {
    if (is.null(xcoord))
    xcoord <- "x"
    if (is.null(ycoord))
    ycoord <- "y"
    temp <- match(c(xcoord, ycoord), names(att.frame),
    nomatch = 0)
    if (any(temp == 0))
    stop(paste("\nThe names for one or both of the columns containing the x-coordinates and \ny-coordinates, \"",
    xcoord, "\" and \"", ycoord, "\", \ndo not occur among the column names in att.frame.",
    sep = ""))
    }
    if (length(do.sample) > 1) {
    if (length(do.sample) != length(design))
    stop("\nArgument do.sample must be the same length as the design list.")
    if (is.null(names(do.sample))) {
    names(do.sample) <- strata.names
    }
    else {
    temp <- match(names(do.sample), strata.names,
    nomatch = 0)
    if (any(temp) == 0)
    temp.str <- vecprint(names(do.sample)[temp ==
    0])
    stop(paste("\nThe following names in do.sample do not occur among the names in design:\n",
    temp.str, sep = ""))
    }
    }
    else if (is.null(names(do.sample))) {
    names(do.sample) <- strata.names
    }
    for (s in strata.names) {
    cat(paste("\nStratum:", s, "\n"))
    temp <- att.frame[, stratum] == s
    grtspts.ind <- TRUE
    if (sum(temp) == 0) {
    warning(paste("\nThe stratum column in the attributes data frame contains no values that match \nthe stratum named \"",
    s, "\" in the design list.\n", sep = ""))
    next
    }
    else if (sum(temp) == 1) {
    warning(paste("\nThe stratum column in the attributes data frame contains a single value that \nmatches the stratum named \"",
    s, "\" in the design list. \nThe sample for this stratum will be composed of a single point.\n",
    sep = ""))
    grtspts.ind <- FALSE
    }
    if (design[[s]]$seltype == "Equal") {
    sframe <- data.frame(id = I(att.frame[temp, id]),
    x = att.frame[temp, xcoord], y = att.frame[temp,
    ycoord], mdcaty = rep("Equal", nrow(att.frame[temp,
    ])))
    }
    else if (design[[s]]$seltype == "Unequal") {
    sframe <- data.frame(id = I(att.frame[temp, id]),
    x = att.frame[temp, xcoord], y = att.frame[temp,
    ycoord], mdcaty = factor(att.frame[temp,
    mdcaty]))
    }
    else if (design[[s]]$seltype == "Continuous") {
    sframe <- data.frame(id = I(att.frame[temp, id]),
    x = att.frame[temp, xcoord], y = att.frame[temp,
    ycoord], mdcaty = att.frame[temp, mdcaty])
    }
    else {
    stop(paste("\nThe value provided for the type of random selection, \"",
    design[[s]]$seltype, "\", \nfor stratum \"",
    s, "\" is not valid.", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    if (any(is.na(sframe$mdcaty)))
    stop(paste("\nMissing values were detected among the unequal probability category values for \nstratum \"",
    s, "\".", sep = ""))
    }
    else if (design[[s]]$seltype == "Continuous") {
    if (any(is.na(sframe$mdcaty)))
    stop(paste("\nMissing values were detected among the unequal probability category values for \nstratum \"",
    s, "\".", sep = ""))
    if (!is.numeric(sframe$mdcaty))
    stop(paste("\nThe type of random selection for stratum \"",
    s, "\" is \"Continuous\", \nbut the unequal probability category values are not numeric.",
    sep = ""))
    if (any(sframe$mdcaty < 0))
    stop(paste("\nNonpositive values were detected among the unequal probability category values \nfor stratum \"",
    s, "\".", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    if (is.null(design[[s]]$caty.n))
    stop(paste("The type of random selection was set to \"Unequal\", but caty.n was not \nprovided for stratum \"",
    s, "\".", sep = ""))
    temp <- match(names(design[[s]]$caty.n), levels(as.factor(sframe$mdcaty)),
    nomatch = 0)
    if (any(temp == 0)) {
    temp.str <- vecprint(names(design[[s]]$caty.n)[temp ==
    0])
    stop(paste("\nThe following names in caty.n for stratum \"",
    s, "\" do not occur \namong the levels of the mdcaty variable in att.frame:\n",
    temp.str, sep = ""))
    }
    }
    if (!is.numeric(design[[s]]$panel))
    stop(paste(" The design list must contain numeric values in the panel argument for \nstratum \"",
    s, "\".\n", sep = ""))
    design[[s]]$panel <- round(design[[s]]$panel)
    design[[s]]$panel <- design[[s]]$panel[design[[s]]$panel >
    0]
    if (length(design[[s]]$panel) == 0)
    stop(paste(" The design list does not not contain any valid values of the panel \nargument for stratum \"",
    s, "\".\n", sep = ""))
    if (design[[s]]$seltype == "Unequal") {
    if (!is.numeric(design[[s]]$caty.n))
    stop(paste(" The design list must contain numeric values in the caty.n argument for \nstratum \"",
    s, "\".\n", sep = ""))
    design[[s]]$caty.n <- round(design[[s]]$caty.n)
    design[[s]]$caty.n <- design[[s]]$caty.n[design[[s]]$caty.n >
    0]
    if (length(design[[s]]$caty.n) == 0)
    stop(paste(" The design list does not not contain any valid values of the caty.n \nargument for stratum \"",
    s, "\".\n", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    temp <- sframe$mdcaty %in% names(design[[s]]$caty.n)
    if (any(!temp)) {
    sframe <- sframe[temp, ]
    }
    }
    if (is.null(design[[s]]$over))
    design[[s]]$over <- 0
    if (design[[s]]$seltype != "Unequal") {
    samplesize <- sum(design[[s]]$panel)
    n.desired <- sum(samplesize, design[[s]]$over)
    }
    else {
    if (sum(design[[s]]$panel) != sum(design[[s]]$caty.n))
    stop("\nThe sum of panel sample sizes does not equal sum of caty.n sample sizes")
    samplesize <- sum(design[[s]]$caty.n)
    if (design[[s]]$over == 0) {
    n.desired <- design[[s]]$caty.n
    }
    else {
    over.n <- design[[s]]$over * design[[s]]$caty.n/sum(design[[s]]$caty.n)
    if (any(over.n != floor(over.n)))
    warning(paste("\nOversample size is not proportional to category sample sizes for stratum\n\"",
    s, "\".\n", sep = ""))
    n.desired <- design[[s]]$caty.n + ceiling(over.n)
    }
    }
    if (design[[s]]$seltype == "Equal")
    sframe$mdm <- mdmpts(sframe$mdcaty, c(Equal = n.desired))
    else if (design[[s]]$seltype == "Unequal")
    sframe$mdm <- mdmpts(sframe$mdcaty, n.desired)
    else sframe$mdm <- n.desired * sframe$mdcaty/sum(sframe$mdcaty)
    if (grtspts.ind) {
    stmp <- grtspts(src.frame, in.shape, sframe,
    sum(n.desired), SiteBegin, shift.grid, do.sample[s],
    startlev, maxlev)
    }
    else {
    stmp <- data.frame(siteID = SiteBegin, id = sframe$id,
    xcoord = sframe$x, ycoord = sframe$y, mdcaty = sframe$mdcaty,
    wgt = 1/sframe$mdm)
    row.names(stmp) <- 1
    attr(stmp, "nlev") <- NA
    }
    if (nrow(stmp) < sum(n.desired))
    warning(paste("\nThe size of the selected sample was less than the desired size for stratum\n\"",
    s, "\".\n", sep = ""))
    stmp$stratum <- as.factor(rep(s, nrow(stmp)))
    stmp$panel <- as.character(rep("OverSamp", nrow(stmp)))
    n.panel <- length(design[[s]]$panel)
    if (nrow(stmp) < samplesize) {
    n.short <- samplesize - nrow(stmp)
    n.temp <- n.short/n.panel
    if (n.temp != floor(n.temp)) {
    n.temp <- c(ceiling(n.temp), rep(floor(n.temp),
    n.panel - 1))
    i <- 1
    while (sum(n.temp) != n.short) {
    i <- i + 1
    n.temp[i] <- n.temp[i] + 1
    }
    }
    np <- c(0, cumsum(design[[s]]$panel - n.temp))
    }
    else {
    np <- c(0, c?gtumsum(design[[s]]$panel))
    }
    for (i in 1:n.panel) stmp$panel[(np[i] + 1):np[i +
    1]] <- names(design[[s]]$panel[i])
    if (design[[s]]$over > 0 || nrow(stmp) < samplesize) {
    if (design[[s]]$seltype != "Unequal") {
    if (nrow(stmp) < samplesize) {
    stmp$wgt <- n.desired * stmp$wgt/nrow(stmp)
    }
    else {
    stmp$wgt <- n.desired * stmp$wgt/samplesize
    }
    }
    else {
    if (nrow(stmp) < samplesize) {
    n.caty <- length(design[[s]]$caty.n)
    n.temp <- n.short/n.caty
    nc <- design[[s]]$caty.n - n.temp
    }
    else {
    nc <- design[[s]]$caty.n
    }
    for (i in names(n.desired)) {
    stmp$wgt[stmp$mdcaty == i] <- n.desired[i] *
    stmp$wgt[stmp$mdcaty == i]/nc[i]
    }
    }
    }
    if (first) {
    sites <- stmp
    levels(sites$stratum) <- strata.names
    first <- FALSE
    }
    else {
    sites <- rbind(sites, stmp)
    }
    SiteBegin <- SiteBegin + nrow(stmp)
    }
    }
    else if (type.frame == "linear") {
    first <- TRUE
    SiteBegin <- SiteBegin
    if (is.null(att.frame$length_mdm)) {
    temp <- .Call("getRecordShapeSizes", in.shape)
    if (length(temp) != nrow(att.frame))
    stop("\nThe number of rows in the attribute data frame does not equal the number of \nrecords in the shapefile(s) in the working directory.")
    att.frame$length_mdm <- temp
    }
    elmsize <- "length_mdm"
    for (s in strata.names) {
    cat(paste("\nStratum:", s, "\n"))
    temp <- att.frame[, stratum] == s
    if (sum(temp) == 0) {
    warning(paste("\nThe stratum column in the attributes data frame contains no values that match \nthe stratum named \"",
    s, "\" in the design list.\n", sep = ""))
    next
    }
    if (design[[s]]$seltype == "Equal") {
    sframe <- data.frame(id = att.frame[temp, id],
    mdcaty = rep("Equal", nrow(att.frame[temp,
    ])), len = att.frame[temp, elmsize])
    }
    else if (design[[s]]$seltype == "Unequal") {
    sframe <- data.frame(id = att.frame[temp, id],
    mdcaty = factor(att.frame[temp, mdcaty]), len = att.frame[temp,
    elmsize])
    }
    else if (design[[s]]$seltype == "Continuous") {
    sframe <- data.frame(id = att.frame[temp, id],
    mdcaty = att.frame[temp, mdcaty], len = att.frame[temp,
    elmsize])
    }
    else {
    stop(paste("\nThe value provided for the type of random selection, \"",
    design[[s]]$seltype, "\", \nfor stratum \"",
    s, "\" is not valid.", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    if (any(is.na(sframe$mdcaty)))
    stop(paste("\nMissing values were detected among the unequal probability category values for \nstratum \"",
    s, "\".", sep = ""))
    }
    else if (design[[s]]$seltype == "Continuous") {
    if (any(is.na(sframe$mdcaty)))
    stop(paste("\nMissing values were detected among the unequal probability category values for \nstratum \"",
    s, "\".", sep = ""))
    if (!is.numeric(sframe$mdcaty))
    stop(paste("\nThe type of random selection for stratum \"",
    s, "\" is \"Continuous\", \nbut the unequal probability category values are not numeric.",
    sep = ""))
    if (any(sframe$mdcaty < 0))
    stop(paste("\nNonpositive values were detected among the unequal probability category values \nfor stratum \"",
    s, "\".", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    if (is.null(design[[s]]$caty.n))
    stop(paste("The type of random selection was set to \"Unequal\", but caty.n was not \nprovided for stratum \"",
    s, "\".", sep = ""))
    temp <- match(names(design[[s]]$caty.n), levels(as.factor(sframe$mdcaty)),
    nomatch = 0)
    if (any(temp == 0)) {
    temp.str <- vecprint(names(design[[s]]$caty.n)[temp ==
    0])
    stop(paste("\nThe following names in caty.n for stratum \"",
    s, "\" do not occur \namong the levels of the mdcaty variable in att.frame:\n",
    temp.str, sep = ""))
    }
    }
    if (!is.numeric(design[[s]]$panel))
    stop(paste(" The design list must contain numeric values in the panel argument for \nstratum \"",
    s, "\".\n", sep = ""))
    design[[s]]$panel <- round(design[[s]]$panel)
    design[[s]]$panel <- design[[s]]$panel[design[[s]]$panel >
    0]
    if (length(design[[s]]$panel) == 0)
    stop(paste(" The design list does not not contain any valid values of the panel \nargument for stratum \"",
    s, "\".\n", sep = ""))
    if (design[[s]]$seltype == "Unequal") {
    if (!is.numeric(design[[s]]$caty.n))
    stop(paste(" The design list must contain numeric values in the caty.n argument for \nstratum \"",
    s, "\".\n", sep = ""))
    design[[s]]$caty.n <- round(design[[s]]$caty.n)
    design[[s]]$caty.n <- design[[s]]$caty.n[design[[s]]$caty.n >
    0]
    if (length(design[[s]]$caty.n) == 0)
    stop(paste(" The design list does not not contain any valid values of the caty.n \nargument for stratum \"",
    s, "\".\n", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    temp <- sframe$mdcaty %in% names(design[[s]]$caty.n)
    if (any(!temp)) {
    sframe <- sframe[temp, ]
    }
    }
    if (is.null(design[[s]]$over))
    design[[s]]$over <- 0
    if (design[[s]]$seltype != "Unequal") {
    samplesize <- sum(design[[s]]$panel)
    n.desired <- sum(samplesize, design[[s]]$over)
    }
    else {
    if (sum(design[[s]]$panel) != sum(design[[s]]$caty.n))
    stop("\nThe sum of panel sample sizes does not equal sum of caty.n sample sizes")
    samplesize <- sum(design[[s]]$caty.n)
    if (design[[s]]$over == 0) {
    n.desired <- design[[s]]$caty.n
    }
    else {
    over.n <- design[[s]]$over * design[[s]]$caty.n/sum(design[[s]]$caty.n)
    if (any(over.n != floor(over.n)))
    warning(paste("\nOversample size is not proportional to category sample sizes for stratum\n\"",
    s, "\".\n", sep = ""))
    n.desired <- design[[s]]$caty.n + ceiling(over.n)
    }
    }
    if (design[[s]]$seltype == "Equal")
    sframe$mdm <- mdmlin(sframe$len, sframe$mdcaty,
    c(Equal = n.desired))
    else if (design[[s]]$seltype == "Unequal")
    sframe$mdm <- mdmlin(sframe$len, sframe$mdcaty,
    n.desired)
    else sframe$mdm <- n.desired * sframe$mdcaty/sum(sframe$len *
    sframe$mdcaty)
    stmp <- grtslin(in.shape, sframe, sum(n.desired),
    SiteBegin, shift.grid, startlev, maxlev)
    stmp$stratum <- as.factor(rep(s, nrow(stmp)))
    stmp$panel <- rep("OverSamp", nrow(stmp))
    np <- c(0, cumsum(design[[s]]$panel))
    for (i in 1:length(design[[s]]$panel)) stmp$panel[(np[i] +
    1):np[i + 1]] <- names(design[[s]]$panel[i])
    if (design[[s]]$over > 0) {
    if (design[[s]]$seltype != "Unequal") {
    stmp$wgt <- n.desired * stmp$wgt/samplesize
    }
    else {
    nc <- design[[s]]$caty.n
    for (i in names(n.desired)) {
    stmp$wgt[stmp$mdcaty == i] <- n.desired[i] *
    stmp$wgt[stmp$mdcaty == i]/nc[i]
    }
    }
    }
    if (first) {
    sites <- stmp
    levels(sites$stratum) <- strata.names
    first <- FALSE
    }
    else {
    sites <- rbind(sites, stmp)
    }
    SiteBegin <- SiteBegin + nrow(stmp)
    }
    }
    else if (type.frame == "area") {
    first <- TRUE
    SiteBegin <- SiteBegin
    if (is.null(att.frame$area_mdm)) {
    temp <- .Call("getRecordShapeSizes", in.shape)
    if (length(temp) != nrow(att.frame))
    stop("\nThe number of rows in the attribute data frame does not equal the number of \nrecords in the shapefile(s) in the working directory.")
    att.frame$area_mdm <- temp
    }
    elmsize <- "area_mdm"
    for (s in strata.names) {
    cat(paste("\nStratum:", s, "\n"))
    temp <- att.frame[, stratum] == s
    if (sum(temp) == 0) {
    warning(paste("\nThe stratum column in the attributes data frame contains no values that match \nthe stratum named \"",
    s, "\" in the design list.\n", sep = ""))
    next
    }
    if (design[[s]]$seltype == "Equal") {
    sframe <- data.frame(id = att.frame[temp, id],
    mdcaty = rep("Equal", nrow(att.frame[temp,
    ])), area = att.frame[temp, elmsize])
    }
    else if (design[[s]]$seltype == "Unequal") {
    sframe <- data.frame(id = att.frame[temp, id],
    mdcaty = factor(att.frame[temp, mdcaty]), area = att.frame[temp,
    elmsize])
    }
    else if (design[[s]]$seltype == "Continuous") {
    sframe <- data.frame(id = att.frame[temp, id],
    mdcaty = att.frame[temp, mdcaty], area = att.frame[temp,
    elmsize])
    }
    else {
    stop(paste("\nThe value provided for the type of random selection, \"",
    design[[s]]$seltype, "\", \nfor stratum \"",
    s, "\" is not valid.", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    if (any(is.na(sframe$mdcaty)))
    stop(paste("\nMissing values were detected among the unequal probability category values for \nstratum \"",
    s, "\".", sep = ""))
    }
    else if (design[[s]]$seltype == "Continuous") {
    if (any(is.na(sframe$mdcaty)))
    stop(paste("\nMissing values were detected among the unequal probability category values for \nstratum \"",
    s, "\".", sep = ""))
    if (!is.numeric(sframe$mdcaty))
    stop(paste("\nThe type of random selection for stratum \"",
    s, "\" is \"Continuous\", \nbut the unequal probability category values are not numeric.",
    sep = ""))
    if (any(sframe$mdcaty < 0))
    stop(paste("\nNonpositive values were detected among the unequal probability category values \nfor stratum \"",
    s, "\".", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    if (is.null(design[[s]]$caty.n))
    stop(paste("The type of random selection was set to \"Unequal\", but caty.n was not \nprovided for stratum \"",
    s, "\".", sep = ""))
    temp <- match(names(design[[s]]$caty.n), levels(as.factor(sframe$mdcaty)),
    nomatch = 0)
    if (any(temp == 0)) {
    temp.str <- vecprint(names(design[[s]]$caty.n)[temp ==
    0])
    stop(paste("\nThe following names in caty.n for stratum \"",
    s, "\" do not occur \namong the levels of the mdcaty variable in att.frame:\n",
    temp.str, sep = ""))
    }
    }
    if (!is.numeric(design[[s]]$panel))
    stop(paste(" The design list must contain numeric values in the panel argument for \nstratum \"",
    s, "\".\n", sep = ""))
    design[[s]]$panel <- round(design[[s]]$panel)
    design[[s]]$panel <- design[[s]]$panel[design[[s]]$panel >
    0]
    if (length(design[[s]]$panel) == 0)
    stop(paste(" The design list does not not contain any valid values of the panel \nargument for stratum \"",
    s, "\".\n", sep = ""))
    if (design[[s]]$seltype == "Unequal") {
    if (!is.numeric(design[[s]]$caty.n))
    stop(paste(" The design list must contain numeric values in the caty.n argument for \nstratum \"",
    s, "\".\n", sep = ""))
    design[[s]]$caty.n <- round(design[[s]]$caty.n)
    design[[s]]$caty.n <- design[[s]]$caty.n[design[[s]]$caty.n >
    0]
    if (length(design[[s]]$caty.n) == 0)
    stop(paste(" The design list does not not contain any valid values of the caty.n \nargument for stratum \"",
    s, "\".\n", sep = ""))
    }
    if (design[[s]]$seltype == "Unequal") {
    temp <- sframe$mdcaty %in% names(design[[s]]$caty.n)
    if (any(!temp)) {
    sframe <- sframe[temp, ]
    }
    }
    if (is.null(design[[s]]$over))
    design[[s]]$over <- 0
    if (design[[s]]$seltype != "Unequal") {
    samplesize <- sum(design[[s]]$panel)
    n.desired <- sum(samplesize, design[[s]]$over)
    }
    else {
    if (sum(design[[s]]$panel) != sum(design[[s]]$caty.n))
    stop("\nThe sum of panel sample sizes does not equal sum of caty.n sample sizes")
    samplesize <- sum(design[[s]]$caty.n)
    if (design[[s]]$over == 0) {
    n.desired <- design[[s]]$caty.n
    }
    else {
    over.n <- design[[s]]$over * design[[s]]$caty.n/sum(design[[s]]$caty.n)
    if (any(over.n != floor(over.n)))
    warning(paste("\nOversample size is not proportional to category sample sizes for stratum\n\"",
    s, "\".\n", sep = ""))
    n.desired <- design[[s]]$caty.n + ceiling(over.n)
    }
    }
    if (design[[s]]$seltype == "Equal")
    sframe$mdm <- mdmarea(sframe$area, sframe$mdcaty,
    c(Equal = n.desired))
    else if (design[[s]]$seltype == "Unequal")
    sframe$mdm <- mdmarea(sframe$area, sframe$mdcaty,
    n.desired)
    else sframe$mdm <- n.desired * sframe$mdcaty/sum(sframe$area *
    sframe$mdcaty)
    stmp <- grtsarea(in.shape, sframe, sum(n.desired),
    SiteBegin, shift.grid, startlev, maxlev, maxtry)
    if (nrow(stmp) < sum(n.desired))
    warning(paste("\nThe size of the selected sample was less than the desired size for stratum \n\"",
    s, "\".\n", sep = ""))
    stmp$stratum <- as.factor(rep(s, nrow(stmp)))
    stmp$panel <- as.character(rep("OverSamp", nrow(stmp)))
    n.panel <- length(design[[s]]$panel)
    if (nrow(stmp) < samplesize) {
    n.short <- samplesize - nrow(stmp)
    n.temp <- n.short/n.panel
    if (n.temp != floor(n.temp)) {
    n.temp <- c(ceiling(n.temp), rep(floor(n.temp),
    n.panel - 1))
    i <- 1
    while (sum(n.temp) != n.short) {
    i <- i + 1
    ntemp[i] <- n.temp[i] + 1
    }
    }
    np <- c(0, cumsum(design[[s]]$panel - n.temp))
    }
    else {
    np <- c(0, cumsum(design[[s]]$panel))
    }
    for (i in 1:n.panel) stmp$panel[(np[i] + 1):np[i +
    1]] <- (design[[s]]$panel[i])
    if (design[[s]]$over > 0 || nrow(stmp) < samplesize) {
    if (design[[s]]$seltype != "Unequal") {
    if (nrow(stmp) < samplesize) {
    stmp$wgt <- n.desired * stmp$wgt/nrow(stmp)
    }
    else {
    stmp$wgt <- n.desired * stmp$wgt/samplesize
    }
    }
    else {
    if (nrow(stmp) < samplesize) {
    n.caty <- length(design[[s]]$caty.n)
    n.temp <- n.short/n.caty
    nc <- design[[s]]$caty.n - n.temp
    }
    else {
    nc <- design[[s]]$caty.n
    }
    for (i in names(n.desired)) {
    stmp$wgt[stmp$mdcaty == i] <- n.desired[i] *
    stmp$wgt[stmp$mdcaty == i]/nc[i]
    }
    }
    }
    if (first) {
    sites <- stmp
    levels(sites$stratum) <- strata.names
    first <- FALSE
    }
    else {
    sites <- rbind(sites, stmp)
    }
    SiteBegin <- SiteBegin + nrow(stmp)
    }
    }
    else {
    stop(paste("\nThe value provided for the type of frame, \"",
    type.frame, "\", is not valid.", sep = ""))
    }
    if (sp.ind) {
    file.remove(paste(in.shape, ".dbf", sep = ""), paste(in.shape,
    ".shp", sep = ""), paste(in.shape, ".shx", sep = ""))
    }
    sites$siteID <- as.character(gsub(" ", "0", paste(DesignID,
    "-", format(sites$siteID), sep = "")))
    sites$EvalStatus <- rep("NotEval", nrow(sites))
    sites$EvalReason <- rep(" ", nrow(sites))
    tm <- match(sites$id, att.frame[, id])
    if (design[[s]]$seltype == "Equal")
    td <- match(c(id, stratum), names(att.frame))
    else td <- match(c(id, stratum, mdcaty), names(att.frame))
    temp <- names(att.frame)[-td]
    if (length(temp) > 0) {
    sites <- cbind(sites, att.frame[tm, -td])
    if (length(temp) == 1)
    names(sites)[ncol(sites)] <- temp
    }
    sites <- sites[, -match("id", names(sites))]
    if (type.frame == "finite" && src.frame == "shapefile")
    sites <- sites[, -match(c("x", "y"), names(sites))]
    if (src.frame == "shapefile") {
    if (type.frame == "linear")
    sites <- sites[, -match("length_mdm", names(sites))]
    else if (type.frame == "area")
    sites <- sites[, -match("area_mdm", names(sites))]
    }
    n <- nrow(sites)
    IDs <- as.character(1:n)
    row.names(sites) <- IDs
    attr(sites, "design") <- design
    ifelse(is.null(startlev), attr(sites, "startlev") <- "Not specified",
    attr(sites, "startlev") <- startlev)
    ifelse(is.null(maxlev), attr(sites, "maxlev") <- "Not specified",
    attr(sites, "maxlev") <- maxlev)
    attr(sites, "endlev") <- attributes(stmp)$nlev
    attr(sites, "maxtry") <- maxtry
    attr(sites, "shift.grid") <- shift.grid
    attr(sites, "do.sample") <- do.sample
    SpointsMat <- matrix(0, nrow = n, ncol = 2)
    rownames(SpointsMat) <- IDs
    SpointsMat[, 1] <- sites[, 2]
    SpointsMat[, 2] <- sites[, 3]
    sp.obj <- SpatialPointsDataFrame(SpatialPoints(SpointsMat),
    data = sites)
    if (shapefile == TRUE) {
    temp <- sapply(sites, is.factor)
    if (any(temp)) {
    sites.tmp <- sites
    for (i in seq(ncol(sites.tmp))[temp]) {
    sites.tmp[, i] <- as.character(sites.tmp[, i])
    temp <- sites.tmp[, i] == "" | is.na(sites.tmp[,
    i])
    if (any(temp)) {
    sites.tmp[temp, i] <- " "
    }
    }
    .Call("writeShapeFilePoint", sites.tmp$xcoord, sites.tmp$ycoord,
    prjfilename, names(sites.tmp), sites.tmp, out.shape)
    }
    else {
    .Call("writeShapeFilePoint", sites$xcoord, sites$ycoord,
    prjfilename, names(sites), sites, out.shape)
    }
    }
    invisible(sp.obj)
    }
    6 changes: 6 additions & 0 deletions stratumdesign.R
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,6 @@
    # for invoking grts
    stratumdesign<- function(ns, points, oversamp) {

    designlist<-list(panel=points,seltype="Equal", over=oversamp)
    return(designlist)
    }
  4. @jer-shiny jer-shiny created this gist Nov 1, 2013.
    22 changes: 22 additions & 0 deletions instructions.html
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,22 @@
    <<!DOCTYPE HTML>
    <html>
    <head>
    <title>How to use this page: </title>
    </head>
    <body>
    <p> This page uses the <a href="http://www.rstudio.com/shiny/"><b>Shiny</b></a> package for R to serve up R statistical tools in a web based interface.
    </p>
    <p> To use this tool, you will need to provide a polygon dataset in ESRI shapefile format. Upload a .zip file (use window to the left), which contains ALL the files that make up a complete ESRI polygon shapefile, to load your dataset into the tool. </p>
    <p>
    The shapefile must contain a field named <b>strata</b> defining the stratum of the dataset, and this MUST be a text (string) based field.
    </p><p>
    This application will display your input polygons in the <b>Plot</b> tab. From there, you can request the number of spatially balanced points you wish to have created, by strata. Oversampled points can also be requested. After selecting 'generate points', the tool will create the points and display them for you, both in the plot, and in table format. Point coordinates in the table are in the same projection as your input dataset.

    AFTER UPLOAD:




    </body>

    </html>
    181 changes: 181 additions & 0 deletions server.R
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,181 @@
    library(tools)
    library(shiny)
    library(rgdal)
    library(spsurvey)
    library(RColorBrewer)
    library(latticeExtra)

    source("stratumdesign.R")
    source("grts2.R")

    # Define server logic
    shinyServer(function(input, output, session) {

    observe({
    x <- input$controller
    })

    mySHPdata <- reactive({

    x<- 0
    updateNumericInput(session, "pts", value = x)
    updateNumericInput(session, "oversamppts", value = x)
    inFile <- input$file1
    if (is.null(inFile))
    return(NULL)
    # unzipping upload is a sys call and depends on platform
    switch(Sys.info()[['sysname']],
    Windows = {
    origdir=getwd()
    setwd(dirname(inFile$datapath))
    system(sprintf(" cd %s", dirname(inFile$datapath)))
    print(getwd())
    system(sprintf("7z e -aoa %s", inFile$datapath))
    setwd(origdir)
    print(getwd())
    },
    Linux = {
    system(sprintf("unzip -tq %s", inFile$datapath))
    })
    shapename <- list.files(dirname(inFile$datapath), pattern="\\.shp$")
    shapename <- file_path_sans_ext(shapename, compression=FALSE)
    print(shapename)

    require(rgdal)
    return (
    readOGR(dirname(inFile$datapath), shapename)
    )
    })

    output$plot <- renderPlot({
    # a variable we can play with, vs the true reactive?
    theSHP<-mySHPdata()
    if(is.null(theSHP))
    return(NULL)
    print(proj4string(theSHP))
    # ok so whereabouts are we
    limitspoly=bbox(theSHP)
    minx=limitspoly[1]
    miny=limitspoly[2]
    maxx=limitspoly[3]
    maxy=limitspoly[4]

    #factor strata values
    print(theSHP$n)
    print(theSHP$fid)
    theSHP$n=as.factor(theSHP$n)

    layer1<-spplot(theSHP, c("n"), xlim=c(minx,maxx), ylim=c(miny,maxy),
    col.regions=brewer.pal(nlevels(theSHP$n), "Accent"))
    if (input$pts >= 1) {
    # if(1==1){
    gimmie<-plotpoints()
    layer2<-spplot(gimmie, c("n"), col.regions="black")
    print(layer1 + layer2)
    }
    else
    print(layer1)
    })

    # make our sample design and invoke grts from spsurvey
    grtsPointData <- reactive({
    if(input$pts == 0)
    return(NULL)
    # non-reactive shp we can manipulate
    theSHP<-mySHPdata()
    if(is.null(theSHP))
    return(NULL)
    print(length(theSHP$strata))
    numstrata<-unique(theSHP$strata)
    print("numstrata is ")
    print(numstrata)

    # make dummy first entry for list we will concat to
    wholedesign=list(NULL)
    for (i in 1:length(numstrata)) {
    print(numstrata[i])

    temp<-list(stratumdesign(numstrata[i],
    isolate(input$pts), isolate(input$oversamppts)))
    names(temp) <- numstrata[i]
    wholedesign<-c(wholedesign, temp)

    }

    wholedesign[[1]]<-NULL
    print(wholedesign)
    # diagnostic
    save(wholedesign, file="wholedesign")

    # create numbered list of entries in shapefile
    howmany<-length(theSHP)
    ids<-1:howmany
    dat<-theSHP@data
    dat$ID<-ids
    theSHP@data<-dat
    save(theSHP, file="shapedata")
    writeOGR(theSHP, ".", "rgdaltest2", driver="ESRI Shapefile", overwrite_layer=TRUE)
    test.attframe<- read.dbf("rgdaltest2")
    result <- grts2(design=as.list(wholedesign), src.frame="sp.object", sp.object=theSHP, type.frame="area",
    stratum="strata", id="ID",
    att.frame=test.attframe,
    prjfilename="rgdaltest2",
    out.shape="grtstest")
    # x<- 0
    # updateNumericInput(session, "pts", value = x)
    # updateNumericInput(session, "oversamppts", value = x)

    save(result, file="result")
    writeOGR(result, ".", "results", driver="ESRI Shapefile", overwrite_layer=TRUE)
    print("DONE creating sample locations!")
    file.copy("rgdaltest2.prj", "results.prj", overwrite=TRUE)

    # create zip fle in case user wants the points
    types<-list.files(pattern="results")
    types_as_string = as.character(types[[1]])
    if (length(types) > 1) for (j in 2:length(types))
    types_as_string = paste(types_as_string," ",as.character(types[[j]]),sep="")
    # unzipping upload is a sys call and depends on platform
    switch(Sys.info()[['sysname']],
    Windows = {
    # origdir=getwd()
    # setwd(dirname(inFile$datapath))
    # system(sprintf(" cd %s", dirname(inFile$datapath)))
    # print(getwd())

    system(sprintf("7z a -tzip results.zip %s", types_as_string))
    # setwd(origdir)
    # print(getwd())
    },
    Linux = {
    allshp<-list.files(pattern="results")
    system(sprintf("zip results %s %s %s", types_as_string))
    })
    return(result)
    })

    output$pointdata <- renderTable({
    temp<- as.data.frame(grtsPointData())
    temp2<- temp[,c("siteID", "xcoord", "ycoord", "stratum")]
    })
    plotpoints <- reactive({
    return(grtsPointData())

    })

    output$downloadData <- downloadHandler(
    filename = function() {
    paste('result-', Sys.Date(), '.zip')
    },
    content = function(file) {
    file.copy("results.zip", file)
    }
    )



    })




    88 changes: 88 additions & 0 deletions ui.R
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,88 @@
    library(shiny)


    shinyUI(pageWithSidebar(

    # Application title
    headerPanel("Spatially Balanced Sampling Tool"),

    sidebarPanel(
    tags$head(
    tags$style(type="text/css", "select { max-width: 175px; }"),
    tags$style(type="text/css", "textarea { max-width: 150px; }"),
    tags$style(type="text/css", ".jslider { max-width: 150px; }"),
    tags$style(type='text/css', ".well { max-width: 200px; }"),
    tags$style(type='text/css', ".span4 { max-width: 200px; }")
    ),

    # conditionalPanel(condition="input.conditionedPanels == 1",
    fileInput('file1', 'Choose .ZIP Shapefile:', multiple=TRUE,
    accept=c('binary'))
    # ),

    # conditionalPanel(condition="input.conditionedPanels >= 2",

    ),

    mainPanel(

    tabsetPanel(

    tabPanel("Instructions",
    includeHTML("instructions.html"),
    div(id="linkToMap", tags$a("Click here to see a map of your input data and create points")),
    div(id="linkToPoints", tags$a("Click here to see table of created points")),
    value=1
    ),

    tabPanel("Plot",
    numericInput("pts", "# of sampling points per stratum:", 0),
    numericInput("oversamppts", "# to OVER sample (optional):", 0),
    submitButton("Generate Points"),

    helpText("Map of input polygons by strata"),
    plotOutput("plot"),
    value=2
    ),
    tabPanel("View Points", helpText("suggested sampling points"),
    downloadLink('downloadData', 'Download Points as shapefile'),
    helpText(" "),
    tableOutput("pointdata"),

    HTML("<script>$('#linkToMap').click(function() {
    tabs = $('.tabbable .nav.nav-tabs li')
    tabs.each(function() {
    $(this).removeClass('active')
    })
    $(tabs[1]).addClass('active')
    tabsContents = $('.tabbable .tab-content .tab-pane')
    tabsContents.each(function() {
    $(this).removeClass('active')
    })
    $(tabsContents[1]).addClass('active')
    $('#plot').trigger('change').trigger('shown')
    })</script>
    "),
    HTML("<script>$('#linkToPoints').click(function() {
    tabs = $('.tabbable .nav.nav-tabs li')
    tabs.each(function() {
    $(this).removeClass('active')
    })
    $(tabs[2]).addClass('active')
    tabsContents = $('.tabbable .tab-content .tab-pane')
    tabsContents.each(function() {
    $(this).removeClass('active')
    })
    $(tabsContents[2]).addClass('active')
    $('#pointdata').trigger('change').trigger('shown')
    })</script>
    "),

    value=3),
    id = "conditionedPanels")
    ))
    )