-
-
Save addame/8734116 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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) | |
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| <!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 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: |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| library(tools) | |
| library(shiny) | |
| library(rgdal) | |
| library(spsurvey) | |
| library(RColorBrewer) | |
| 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 | |
| }) | |
| # observe({ | |
| # updateTextInput(session, "strataname", "strata") | |
| # }) | |
| readSHPdata <- reactive({ | |
| x<- 0 | |
| enable(updateNumericInput(session, "pts", value = x)) | |
| enable(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 = { | |
| 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) | |
| 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() | |
| 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] | |
| print(limitspoly) | |
| #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('stratum'), 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) | |
| isolate({ | |
| # non-reactive shp we can manipulate | |
| theSHP<-mySHPdata() | |
| if(is.null(theSHP)) | |
| return(NULL) | |
| 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 | |
| wholedesign=list(NULL) | |
| for (i in 1:length(numstrata)) { | |
| print(numstrata[i]) | |
| temp<-list(stratumdesign(numstrata[i], | |
| input$pts, 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") | |
| grtsstrata <- "shnystr" | |
| result <- grts2(design=as.list(wholedesign), src.frame="sp.object", sp.object=theSHP, type.frame="area", | |
| stratum=grtsstrata, id="ID", | |
| att.frame=test.attframe, | |
| prjfilename="rgdaltest2", | |
| out.shape="grtstest") | |
| # 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) | |
| 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({ | |
| save(grtsPointData, file="grtsPointData") | |
| return(grtsPointData()) | |
| }) | |
| output$downloadData <- downloadHandler( | |
| filename = function() { | |
| paste('result-', Sys.Date(), '.zip') | |
| }, | |
| content = function(file) { | |
| file.copy("results.zip", file) | |
| } | |
| ) | |
| }) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # for invoking grts | |
| stratumdesign<- function(ns, points, oversamp) { | |
| designlist<-list(panel=points,seltype="Equal", over=oversamp) | |
| return(designlist) | |
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| library(shiny) | |
| shinyUI(pageWithSidebar( | |
| # Application title | |
| headerPanel("Spatially Balanced Sampling Tool"), | |
| sidebarPanel( | |
| tags$head( | |
| 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; }") | |
| ), | |
| 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') | |
| ), | |
| 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, | |
| HTML('<img style="float: right"; src="JornadaLogo_1.png"/>') | |
| ), | |
| tabPanel("Plot", | |
| # | |
| # 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(outputId = "plot"), | |
| value=2 | |
| ), | |
| tabPanel("View Points", helpText("suggested sampling points"), | |
| helpText(" "), | |
| tableOutput(outputId = "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") | |
| )) | |
| ) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment