iNZSurveyDesign <- setRefClass(
"iNZSurveyDesign",
contains = "iNZWindow",
fields = list(
svytype = "character",
freqVar = "ANY",
stratVar = "ANY",
clus1Var = "ANY",
clus2Var = "ANY",
nestChk = "ANY",
wtVar = "ANY",
popSize = "ANY",
fpcVar = "ANY",
fpcVar2 = "ANY",
combWts = "ANY",
repVars = "ANY",
repType = "ANY",
repScale = "ANY",
repRscalesBtn = "ANY",
repRscalesClear = "ANY",
repRscales = "ANY",
rscalesTbl = "ANY",
readFileBtn = "ANY",
createBtn = "ANY",
cancelBtn = "ANY"
),
methods = list(
initialize = function(gui, type = c("survey", "replicate", "frequency")) {
if (is.null(gui$getActiveData(lazy = TRUE))) {
gerror("Please import a data set first.",
title = "No data set",
icon = "error"
)
return()
}
if (names(gui$getActiveData(lazy = TRUE))[1] == "empty") {
gmessage("Please import a data set first.",
title = "No data set",
icon = "error"
)
return()
}
initFields(svytype = match.arg(type))
ok <- callSuper(gui,
title = switch(svytype,
"survey" = "Specify Complex Survey Design",
"replicate" = "Specify Survey Design with Replicate Weights",
"frequency" = "Specify frequency column"
),
width = switch(svytype,
"replicate" = "large",
"small"
),
height = switch(svytype,
"frequency" = "small",
"med"
),
help = switch(svytype,
"frequency" = "user_guides/data_options/#freqtables",
"user_guides/data_options/#svydesign"
),
ok = "Create",
action = .self$create,
show_code = FALSE,
scroll = FALSE
)
if (!ok) {
return()
}
on.exit(.self$show())
usingMethods("create")
pnl <- switch(svytype,
"survey" = set_design(),
"replicate" = set_repdesign(),
"frequency" = set_frequency()
)
add_body(pnl)
readFileBtn <<- gbutton("Read from file",
handler = function(h, ...) read_file()
)
readFileBtn$set_icon("gw-file")
add_toolbar(readFileBtn)
## Populate the lists:
curDes <- GUI$getActiveDoc()$getModel()$getDesign()
if (is.null(curDes)) {
return()
}
spec <- curDes$spec
switch(svytype,
"survey" = {
if (!is.null(spec$strata)) {
svalue(stratVar) <<- spec$strata
}
if (!is.null(spec$ids) && spec$ids != 1) {
clus <- trimws(strsplit(spec$ids, "+", fixed = TRUE)[[1]])
svalue(clus1Var) <<- clus[1]
if (length(clus) == 2L) {
svalue(clus2Var) <<- clus[2]
}
}
if (!is.null(spec$nest)) {
svalue(nestChk) <<- spec$nest
}
if (!is.null(spec$weights)) {
svalue(wtVar) <<- spec$weights
}
# TO DO: special handling here
if (!is.null(spec$fpc)) {
fpc <- trimws(strsplit(spec$fpc, "+", fixed = TRUE)[[1]])
svalue(fpcVar) <<- fpc[1]
if (length(fpc) == 2L) {
svalue(fpcVar2) <<- fpc[2]
}
}
},
"replicate" = {
if (!is.null(spec$weights)) {
svalue(wtVar) <<- spec$weights
}
if (!is.null(spec$repweights)) {
# suppress warning from bug in gWidgets2:
suppressWarnings(
svalue(repVars) <<- spec$repweights
)
if (!is.null(spec$rscales)) {
repRscales <<- data.frame(
rep.weight = spec$repweights,
rscales = spec$rscales,
stringsAsFactors = TRUE
)
display_scales()
}
}
if (!is.null(spec$type)) {
svalue(repType) <<- spec$type
}
if (!is.null(spec$scale)) {
svalue(repScale) <<- spec$scale
}
},
"freq" = {
if (!is.null(spec$freq)) {
svalue(freqVar) <<- spec$freq
}
}
)
},
svalue_or_null = function(x) {
if (svalue(x) == "") {
return(NULL)
}
svalue(x)
},
calculate_population_size = function() {
svalue(popSize) <<- ""
svy <- try(create(preview = TRUE), silent = TRUE)
if (inherits(svy, "try-error")) {
return()
}
if (!requireNamespace("survey", quietly = TRUE)) {
p <- gconfirm("You need to install additional packages. Do it now?",
"Install required packages?",
icon = "question",
parent = GUI$win
)
if (!p) {
gmessage("Unable to set survey design.",
parent = GUI$win
)
return()
}
install.packages("survey")
}
wts <- switch(svytype,
"survey" = survey:::weights.survey.design(svy),
"replicate" = survey:::weights.svyrep.design(svy)
)
svalue(popSize) <<- format(
sum(wts),
nsmall = 0L,
big.mark = ",",
scientific = FALSE
)
},
create = function(preview = FALSE) {
if (!requireNamespace("surveyspec", quietly = TRUE)) {
p <- gconfirm("You need to install additional packages. Do it now?",
"Install required packages?",
icon = "question",
parent = GUI$win
)
if (!p) {
gmessage("Unable to set survey design.",
parent = GUI$win
)
return()
}
install.packages("surveyspec")
}
switch(svytype,
"survey" = {
strat <- svalue_or_null(stratVar)
clus1 <- svalue_or_null(clus1Var)
clus2 <- svalue_or_null(clus2Var)
if (!is.null(clus1) && !is.null(clus2)) {
clus <- paste(clus1, clus2, sep = " + ")
} else if (is.null(clus1) && is.null(clus2)) {
clus <- "1"
} else {
clus <- ifelse(is.null(clus1), clus2, clus1)
}
wts <- svalue_or_null(wtVar)
fpc1 <- svalue_or_null(fpcVar)
fpc2 <- svalue_or_null(fpcVar2)
if (!is.null(fpc1) && !is.null(fpc2)) {
fpc <- paste(fpc1, fpc2, sep = " + ")
} else if (is.null(fpc1) && is.null(fpc2)) {
fpc <- NULL
} else {
fpc <- ifelse(is.null(fpc1), fpc2, fpc1)
}
nest <- as.logical(svalue(nestChk))
clear <- is.null(strat) && is.null(clus1) &&
is.null(clus2) && is.null(wts) && is.null(fpc)
spec <- list(
strata = strat,
ids = clus,
weights = wts,
nest = nest,
fpc = fpc,
survey_type = "survey"
)
if (preview) {
spec <- surveyspec::make_survey(
GUI$getActiveData(lazy = FALSE),
structure(list(spec = spec), class = "inzsvyspec")
)
return(spec$design)
}
GUI$getActiveDoc()$getModel()$setDesign(
spec,
gui = GUI
)
},
"replicate" = {
wts <- svalue_or_null(wtVar)
repWts <- svalue(repVars, index = FALSE)
reptype <- svalue(repType)
if (reptype %in% c("bootstrap", "other")) {
scale <- as.numeric(svalue(repScale))
rscales <- as.numeric(repRscales$rscales)
if (length(rscales) == 0) {
rscales <- rep(scale, length(repWts))
} else if (any(is.na(rscales))) {
rscales <- NULL
}
} else if (reptype %in% c("JK1")) {
n <- length(repWts)
scale <- (n - 1) / n
rscales <- NULL
} else {
scale <- NULL
rscales <- NULL
}
clear <- is.null(wts) && length(repWts) == 0
spec <- list(
weights = wts,
repweights = repWts,
type = reptype,
scale = scale,
rscales = rscales,
survey_type = "replicate"
)
if (preview) {
spec <- surveyspec::make_survey(
GUI$getActiveData(lazy = FALSE),
structure(
list(spec = spec),
class = "inzsvyspec"
)
)
return(spec$design)
}
GUI$getActiveDoc()$getModel()$setDesign(
spec,
gui = GUI
)
},
"frequency" = {
freqv <- svalue_or_null(freqVar)
GUI$getActiveDoc()$getModel()$setFrequencies(
freq = freqv,
gui = GUI
)
close()
return()
}
)
setOK <- try(
GUI$getActiveDoc()$getModel()$createSurveyObject(),
TRUE
)
if (!inherits(setOK, "try-error")) {
close()
## write design call
call <- paste(deparse(setOK$call), collapse = "\n")
call <- sprintf(
"%s <- %s",
GUI$getActiveDoc()$getModel()$dataDesignName,
gsub("dataSet", GUI$getActiveDoc()$getModel()$name, call)
)
GUI$rhistory$add(
c("## create survey design object\n", call),
tidy = TRUE
)
## update plot
GUI$updatePlot()
} else {
gmessage(
paste0(
"There is a problem with the specification of the survey design:\n\n",
setOK
),
icon = "error"
)
}
},
set_design = function() {
g <- gvbox()
tbl <- glayout(cont = g)
vars <- c("", names(GUI$getActiveData(lazy = TRUE)))
ii <- 2
lbl <- glabel("Strata variable: ")
tbl[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <- lbl
stratVar <<- gcombobox(vars)
tbl[ii, 2, expand = TRUE] <- stratVar
ii <- ii + 1
lbl <- glabel("1st stage clustering variable: ")
tbl[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <- lbl
clus1Var <<- gcombobox(vars)
tbl[ii, 2, expand = TRUE] <- clus1Var
ii <- ii + 1
lbl <- glabel("2nd stage clustering variable: ")
tbl[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <- lbl
clus2Var <<- gcombobox(vars)
tbl[ii, 2, expand = TRUE] <- clus2Var
enabled(clus2Var) <<- FALSE
addHandlerChanged(
clus1Var,
function(h, ...) {
enabled(clus2Var) <<- clus1Var$get_index() > 1L
}
)
addHandlerChanged(
clus2Var,
function(h, ...) {
enabled(fpcVar2) <<- clus2Var$get_index() > 1L
}
)
ii <- ii + 1
nestChk <<- gcheckbox("Use nested sampling")
tbl[ii, 2, expand = TRUE] <- nestChk
ii <- ii + 2
lbl <- glabel("Weighting variable: ")
tbl[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <- lbl
wtVar <<- gcombobox(vars,
handler = function(h, ...) calculate_population_size()
)
tbl[ii, 2, expand = TRUE] <- wtVar
ii <- ii + 1
lbl <- glabel("Finite population correction: ")
tbl[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <- lbl
fpcVar <<- gcombobox(vars,
handler = function(h, ...) calculate_population_size()
)
tbl[ii, 2, expand = TRUE] <- fpcVar
ii <- ii + 1
lbl <- glabel("Finite population correction (2nd stage): ")
tbl[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <- lbl
fpcVar2 <<- gcombobox(vars,
handler = function(h, ...) calculate_population_size()
)
tbl[ii, 2, expand = TRUE] <- fpcVar2
enabled(fpcVar2) <<- FALSE
ii <- ii + 1
lbl <- glabel("Estimated population size: ")
font(lbl) <- list(size = 9)
tbl[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <- lbl
popSize <<- glabel("")
font(popSize) <<- list(size = 9)
tbl[ii, 2, expand = TRUE] <- popSize
g
},
set_repdesign = function() {
g <- ggroup()
g1 <- gvbox(container = g)
vars <- c("", names(GUI$getActiveData(lazy = TRUE)))
## ... weights, combine.weights here ...
tbl <- glayout(container = g1)
ii <- 1
tbl[ii, 1, expand = TRUE, anchor = c(1, 0)] <-
glabel("Sampling weights : ")
wtVar <<- gcombobox(vars,
handler = function(h, ...) calculate_population_size()
)
tbl[ii, 2, expand = TRUE] <- wtVar
ii <- ii + 1
combWts <<- gcheckbox(
"Replication weights incorporate sampling weights",
checked = TRUE,
handler = function(h, ...) calculate_population_size()
)
tbl[ii, 1:2, expand = TRUE, anchor = c(1, 0)] <- combWts
ii <- ii + 1
addSpace(g1, 5)
repVars <<- gtable(vars[-1],
multiple = TRUE, container = g1,
handler = function(h, ...) calculate_population_size()
)
repVars$set_names("Select replicate weights")
size(repVars) <<- c(-1, 320)
lbl <- glabel(
paste(
sep = "\n",
"To select a range, click the first, then hold SHIFT while clicking the last.",
"Hold CTRL while clicking to add and remove invidividual variables."
)
)
font(lbl) <- list(size = 8)
add(g1, lbl)
tbl2 <- glayout(container = g1)
lbl <- glabel("Estimated population size: ")
font(lbl) <- list(size = 9)
tbl2[1L, 1L, expand = TRUE, fill = TRUE, anchor = c(1, 0)] <- lbl
popSize <<- glabel("")
font(popSize) <<- list(size = 9)
tbl2[1L, 2L, expand = TRUE] <- popSize
g2 <- gvbox(container = g, expand = TRUE)
## type, scale, etc.
tbl2 <- glayout(container = g2)
ii <- 1
lbl <- glabel("Type of replication weights: ")
repType <<- gcombobox(
c("BRR", "Fay", "JK1", "JKn", "bootstrap", "other"),
selected = 6,
handler = function(h, ...) calculate_population_size()
)
tbl2[ii, 1, expand = TRUE, anchor = c(1, 0)] <- lbl
tbl2[ii, 2, expand = TRUE] <- repType
ii <- ii + 1
addSpace(g2, 5)
scalesG <- gvbox(container = g2)
tbl3 <- glayout(container = scalesG)
ii <- 1
scalesLbl <- glabel(
"Specify at least one of overall scale and individual replicate scales"
)
font(scalesLbl) <- list(size = 9, weight = "bold")
tbl3[ii, 1:2, expand = TRUE, anchor = c(0, 0)] <- scalesLbl
ii <- ii + 1
lbl <- glabel("Overall scale: ")
repScale <<- gedit("",
handler = function(h, ...) calculate_population_size()
)
tbl3[ii, 1, expand = TRUE, anchor = c(1, 0)] <- lbl
tbl3[ii, 2, expand = TRUE] <- repScale
ii <- ii + 1
lbl <- glabel("Replicate scales: ")
repRscalesBtn <<- gbutton("Read from file ...",
handler = function(h, ...) {
f <- gfile(
type = "open",
filter = c("csv" = "csv")
)
if (length(f) == 0) {
return()
}
set_rscales(f)
}
)
repRscalesClear <<- gbutton("Clear",
handler = function(h, ...) {
repRscales <<- data.frame(
rep.weight = character(),
rscales = numeric(),
stringsAsFactors = TRUE
)
display_scales()
}
)
tbl3[ii, 1, expand = TRUE, anchor = c(1, 0)] <- lbl
tbl3[ii, 2, expand = TRUE] <- repRscalesBtn
tbl3[ii, 3, expand = TRUE] <- repRscalesClear
ii <- ii + 1
lbl <- glabel("File should contain one replicate scale per line.")
font(lbl) <- list(size = 8)
tbl3[ii, 2:3, expand = TRUE, anchor = c(-1, 0)] <- lbl
ii <- ii + 1
## initialize repRscales
repRscales <<-
data.frame(
rep.weight = character(), rscales = numeric(),
stringsAsFactors = TRUE
)
rscalesTbl <<- gtable(repRscales,
handler = function(h, ...) calculate_population_size()
)
tbl3[ii, 2:3, expand = TRUE] <- rscalesTbl
size(rscalesTbl) <<- c(-1, 200)
# addHandlerSelectionChanged(repVars,
# function(h, ...) {
# repRscales <<- data.frame(
# rep.weight = svalue(repVars),
# rscales = rep("", length(svalue(h$obj)))
# )
# display_scales()
# }
# )
addHandlerChanged(
repType,
function(h, ...) {
visible(scalesG) <-
!svalue(h$obj) %in% c("BRR", "Fay", "JK1", "JKn")
}
)
## Return the content container thing
g
},
display_scales = function() {
rscalesTbl$set_items(repRscales)
invisible()
},
set_rscales = function(file) {
# if first row is a character, file has a header
x1 <- readLines(file, n = 1)
file_has_header <- suppressWarnings(is.na(as.numeric(x1)))
df <- read.csv(file, header = file_has_header, stringsAsFactors = TRUE)
if (nrow(df) != length(svalue(repVars))) {
gmessage("You need to specify one scale per replicate.")
return()
}
names(df)[1] <- "rscales"
repRscales <<- cbind(
data.frame(rep.weight = svalue(repVars), stringsAsFactors = TRUE),
df
)
display_scales()
},
set_frequency = function() {
g <- gvbox()
lbl <- glabel("Choose frequency column", cont = g)
font(lbl) <- list(weight = "bold", size = 11)
addSpace(g, 5)
as.int <- function(x) {
is.numeric(x) && all(floor(x) == x, na.rm = TRUE)
}
ints <- sapply(GUI$getActiveData(lazy = FALSE), as.int)
vars <- names(GUI$getActiveData(lazy = TRUE))[ints]
freqVar <<- gcombobox(vars, selected = 0, container = g)
addSpace(g, 5)
lbl <- glabel("WARNING: any non-categorical variables will be removed")
font(lbl) <- list(weight = "bold", size = 9)
add(g, lbl, expand = TRUE, anchor = c(-1, 0))
g
},
read_file = function(file) {
if (missing(file)) {
file <- gfile("Select survey design file",
type = "open",
filter = ".svydesign"
)
if (length(file) == 0) {
return()
}
}
if (!requireNamespace("surveyspec", quietly = TRUE)) {
p <- gconfirm("You need to install additional packages. Do it now?",
"Install required packages?",
icon = "question",
parent = GUI$win
)
if (!p) {
gmessage("Unable to set survey design.",
parent = GUI$win
)
return()
}
install.packages("surveyspec")
}
svyspec <- surveyspec::import_survey(file)
GUI$getActiveDoc()$getModel()$setDesign(svyspec, gui = GUI)
setOK <- try(
GUI$getActiveDoc()$getModel()$createSurveyObject(),
silent = TRUE
)
if (!inherits(setOK, "try-error")) {
close()
## write design call
call <- paste(deparse(setOK$call), collapse = "\n")
call <- sprintf(
"%s <- %s",
GUI$getActiveDoc()$getModel()$dataDesignName,
gsub("dataSet", GUI$getActiveDoc()$getModel()$name, call)
)
GUI$rhistory$add(
c("## create survey design object", call),
tidy = TRUE
)
## update plot
GUI$updatePlot()
} else {
gmessage(
paste0(
"There is a problem with the survey specification file:\n\n",
setOK
),
icon = "error"
)
}
}
)
)
iNZSurveyPostStrat <- setRefClass(
"iNZSurveyPostStrat",
contains = "iNZWindow",
fields = list(
PSvar = "ANY",
PSlvls = "ANY",
lvldf = "list",
okBtn = "ANY",
cancelBtn = "ANY",
rmvBtn = "ANY"
),
methods = list(
initialize = function(gui, .use_ui = TRUE) {
initFields(lvldf = list())
curDes <- gui$getActiveDoc()$getModel()$getDesign()
if (is.null(curDes)) {
if (.use_ui) {
gmessage("Please specify a survey design first",
title = "No design specified",
icon = "warning"
)
} else {
warning("Please specify a survey design first")
}
return(invisible(NULL))
}
curDes <- curDes$spec
ok <- callSuper(gui,
title = "Survey Calibration / Post-stratification",
width = "med",
height = "med",
help = "user_guides/data_options/#post-stratify",
ok = "Calibrate",
action = .self$calibrate,
show_code = FALSE,
scroll = FALSE,
body_direction = "horizontal"
)
if (!ok) {
return()
}
on.exit(.self$show())
usingMethods("calibrate")
## left size panel (choose variables)
g1 <- gvbox()
## only those with no missing values ...
fvars <- sapply(
GUI$getActiveData(lazy = FALSE),
function(v) length(levels(v)) > 0 && sum(is.na(v)) == 0
)
factorvars <- names(GUI$getActiveData(lazy = TRUE))[fvars]
PSvar <<- gtable(factorvars,
multiple = TRUE,
container = g1,
expand = TRUE
)
PSvar$set_names("Choose variables")
size(PSvar) <<- c(200, 380)
addHandlerSelectionChanged(
PSvar,
function(h, ...) update_levels()
)
lbl <- glabel("Hold CTRL or SHIFT to select multiple",
container = g1,
anchor = c(-1, 0),
expand = TRUE
)
font(lbl) <- list(size = 8)
add_body(g1)
body_space(10)
g2 <- gvbox(use.scrollwindow = "y")
## table to populate with levels of variable
gl <- ggroup(container = g2)
PSlvls <<- glayout(container = gl)
addSpace(gl, 20)
add_body(g2, expand = TRUE)
addHandlerChanged(
PSvar,
function(h, ...) update_levels()
)
rmvBtn <<- gbutton("Remove calibration",
handler = function(h, ...) {
svalue(PSvar, index = TRUE) <<- 0
calibrate()
}
)
add_toolbar(rmvBtn)
## populate on load
lvldf <<- GUI$getActiveDoc()$getModel()$getFreqTables()
if (!is.null(curDes$calibrate)) {
svalue(PSvar) <<- names(curDes$calibrate)
display_tbl()
}
## when the window closes, store the lvldf in survey
addHandlerDestroy(
GUI$modWin,
function(h, ...) {
GUI$getActiveDoc()$getModel()$storeFreqTables(lvldf)
}
)
},
update_levels = function(h, ...) {
for (v in svalue(PSvar)) {
if (is.null(lvldf[[v]])) {
d <- data.frame(
a = levels(GUI$getActiveData(lazy = TRUE)[[v]]),
b = NA,
stringsAsFactors = TRUE
)
names(d) <- c(v, "Freq")
lvldf[[v]] <<- d
}
}
display_tbl()
},
set_freqs = function(variable, df) {
## add checks that 2 columns with all necessary levels
names(df) <- c(variable, "Freq")
lvldf[[variable]] <<- df
## now display the information in the UI
display_tbl()
},
set_freq = function(variable, level, freq) {
lvldf[[variable]]$Freq[lvldf[[variable]][, 1] == level] <<-
as.numeric(freq)
},
display_tbl = function() {
# remove existing children from PSlvls
if (length(PSlvls$children)) {
sapply(PSlvls$children, PSlvls$remove_child)
}
# Only display those chosen on the left
if (length(svalue(PSvar)) == 0) {
return()
}
# display lvldf variables selected in tables:
ii <- 1
set_freq_val <- function(h, ...) {
## need a way of figuring out which VARIABLE it is ...
j <- which(sapply(
PSlvls[, 2],
function(z) identical(z, h$obj)
))
set_freq(
svalue(PSlvls[j, 4]), # inivisble variable name
svalue(PSlvls[j, 1]), # variable level
svalue(h$obj) # freq
)
}
for (v in svalue(PSvar)) {
lbl <- glabel(v)
font(lbl) <- list(weight = "bold")
PSlvls[ii, 1, expand = TRUE, fill = FALSE, anchor = c(1, 0)] <<- lbl
lbl <- glabel("Frequency")
font(lbl) <- list(weight = "bold")
PSlvls[ii, 2, expand = TRUE, fill = FALSE, anchor = c(-1, 0)] <<- lbl
lbl <- glabel(v)
visible(lbl) <- FALSE
PSlvls[ii, 4] <<- lbl
for (i in seq_along(1:nrow(lvldf[[v]]))) {
ii <- ii + 1
PSlvls[ii, 1,
expand = TRUE,
fill = TRUE,
anchor = c(1, 0)
] <<- glabel(lvldf[[v]][i, 1])
PSlvls[ii, 2] <<- gedit(
ifelse(is.na(lvldf[[v]][i, 2]), "", lvldf[[v]][i, 2]),
width = 20,
handler = set_freq_val
)
addHandlerKeystroke(PSlvls[ii, 2], set_freq_val)
lbl <- glabel(v)
visible(lbl) <- FALSE
PSlvls[ii, 4] <<- lbl
}
btn <- gbutton("Read from file ...",
handler = function(h, ...) {
f <- gfile(
type = "open",
filter = c("csv" = "csv")
)
if (length(f) == 0) {
return()
}
df <- read.csv(f, stringsAsFactors = TRUE)
rowj <- which(
sapply(
PSlvls[, 3],
function(z) identical(z, h$obj)
)
)
var <- svalue(PSlvls[rowj, 4])
if (ncol(df) != 2) {
gmessage(
paste(
"File needs to have 2 columns: one for variable",
"names, and one for frequencies."
)
)
return()
}
if (nrow(df) != nrow(lvldf[[var]])) {
gmessage("File needs to have one row for each level.")
return()
}
set_freqs(var, df)
}
)
## add button to second-to-last-row
PSlvls[ii - 1, 3, anchor = c(1, 0)] <<- btn
btn <- gbutton("Paste from clipboard ...")
ii <- ii + 2
PSlvls[ii, 1:3] <<- gseparator()
ii <- ii + 2
}
},
calibrate = function() {
curDes <- GUI$getActiveDoc()$getModel()$getDesign()$spec
cal_list <- lapply(
names(lvldf),
function(var) {
x <- lvldf[[var]]$Freq
names(x) <- lvldf[[var]][[var]]
x
}
)
names(cal_list) <- names(lvldf)
GUI$getActiveDoc()$getModel()$setDesign(
modifyList(
curDes,
list(
calibrate =
if (length(svalue(PSvar))) {
cal_list[svalue(PSvar)]
} else {
NULL
}
)
),
gui = GUI
)
setOK <- try(
GUI$getActiveDoc()$getModel()$createSurveyObject(),
TRUE
)
if (inherits(setOK, "try-error")) {
gmessage(
"Something went wrong during post stratification ...",
type = "error"
)
return()
} else {
call <- paste(deparse(setOK$call), collapse = "\n")
call <- sprintf(
"%s <- %s",
GUI$getActiveDoc()$getModel()$dataDesignName,
gsub("design_obj", GUI$getActiveDoc()$getModel()$name, call)
)
GUI$rhistory$add(
c(
ifelse(length(svalue(PSvar)),
"## calibrate survey design",
"## remove survey calibration"
),
call
),
tidy = TRUE
)
}
close()
}
)
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.