#' @importFrom iNZightTools inzdf
iNZDataModel <- setRefClass(
"iNZDataModel",
properties(
fields = list(
dataSet = "ANY",
origDataSet = "ANY",
dataDesign = "ANY",
dataDesignName = "character",
name = "character",
oldname = "character",
freqtables = "list",
currentDesign = "list",
design_only = "logical",
dictionary = "list",
dict_df = "data.frame"
),
prototype = list(
dataSet = iNZightTools::inzdf(
data.frame(empty = " ", stringsAsFactors = TRUE),
name = "(empty)"
),
origDataSet = iNZightTools::inzdf(
data.frame(empty = " ", stringsAsFactors = TRUE),
name = "(empty)"
),
dataDesign = NULL,
name = "data", oldname = "",
freqtables = list(),
currentDesign = list(),
design_only = FALSE,
dictionary = list(),
dict_df = data.frame()
)
),
contains = "PropertySet", ## need this to add observer to object
methods = list(
initialize = function(data = NULL) {
if (is.null(data)) {
return()
}
if (inherits(data, "inzsvyspec")) {
.self$setData(data$data)
.self$setDesign(data)
design_only <<- TRUE
} else {
.self$setData(data)
design_only <<- FALSE
}
},
setData = function(data) {
## validate names
attr(data, "names") <- make.names(colnames(data), unique = TRUE)
## set data name (default = "data")
if (is.null(attr(data, "name", exact = TRUE))) {
attr(data, "name") <- "data"
}
if (!inherits(data, "inzdf")) {
data <- iNZightTools::inzdf(data)
}
dataSet <<- data
origDataSet <<- data
name <<- attr(data, "name", exact = TRUE)
oldname <<- ""
if (!is.null(attr(data, "dictionary", exact = TRUE))) {
setDictionary(attr(data, "dictionary", exact = TRUE))
}
},
updateData = function(data) {
if (inherits(data, "inzsvyspec")) {
dataDesign <<- unclass(data)
invisible(createSurveyObject(reload = TRUE))
data <- data$data
design_only <<- TRUE
}
if (is.null(attr(data, "name", exact = TRUE))) {
attr(data, "name") <- "data"
}
dataSet <<- inzdf(data)
name <<- attr(data, "name", exact = TRUE)
if (!is.null(dataDesign)) createSurveyObject(TRUE)
},
setNames = function(newNames) {
newNames <- make.names(newNames, unique = TRUE)
names(dataSet) <<- newNames
},
getData = function(lazy = FALSE) {
if (lazy) {
return(dataSet)
}
as.data.frame(dataSet)
},
addDataObserver = function(FUN, ...) {
.self$dataSetChanged$connect(FUN, ...)
},
addNameObserver = function(FUN, ...) {
.self$nameChanged$connect(FUN, ...)
},
addObjObserver = function(FUN, ...) {
.self$changed$connect(FUN, ...)
},
removeSignals = function() {
for (i in seq_along(listeners(dataSetChanged))) {
dataSetChanged$disconnect(1)
}
for (i in seq_along(listeners(nameChanged))) {
nameChanged$disconnect(1)
}
for (i in seq_along(listeners(.changed))) {
.changed$disconnect(1)
}
},
setFrequencies = function(freq, gui) {
if (is.null(freq) || freq == "") {
gui$getActiveDoc()$setSettings(list(freq = NULL))
}
gui$getActiveDoc()$setSettings(
list(
freq = as.name(freq)
)
)
# remove any non-categorical variables
newdata <- gui$getActiveData(lazy = TRUE)
vcat <- iNZightTools::vartypes(newdata) == "cat"
catvars <- c(names(newdata)[vcat], freq)
newdata <- as.data.frame(newdata[, catvars])
attr(newdata, "name") <- paste(
sep = ".",
attr(gui$getActiveData(lazy = TRUE), "name", exact = TRUE),
"freq"
)
gui$setDocument(iNZDocument$new(data = newdata, preferences = gui$preferences))
},
setDesign = function(x, gui) {
if (missing(x)) {
dataDesign <<- NULL
dataDesignName <<- name
if (!missing(gui)) {
gui$dataNameWidget$updateWidget()
gui$menuBarWidget$defaultMenu()
}
return()
}
if (!requireNamespace("surveyspec", quietly = TRUE)) {
p <- gconfirm("You need to install additional packages. Do it now?",
"Install required packages?",
icon = "question",
parent = if (!missing(gui)) gui$win else NULL
)
if (!p) {
gmessage("Unable to set survey design.",
parent = if (!missing(gui)) gui$win else NULL
)
return()
}
install.packages("surveyspec")
}
if (inherits(x, "inzsvyspec")) {
spec <- x
if (is.null(x$design)) {
x <- surveyspec::make_survey(getData(), x)
}
} else {
spec <- structure(
list(
spec = list(
ids = if (is.null(x$ids)) 1 else x$ids,
probs = x$probs,
strata = x$strata,
fpc = x$fpc,
nest = as.logical(x$nest),
weights = x$weights,
survey_type = x$survey_type,
repweights = x$repweights,
scale = x$scale,
rscales = x$rscales,
type = x$type,
calibrate = x$calibrate,
calfun = if (is.null(x$calibrate)) NULL else "linear"
)
),
class = "inzsvyspec"
)
x <- surveyspec::make_survey(getData(), spec)
}
if (!is.null(spec$spec$calibrate)) {
cal <- lapply(
names(spec$spec$calibrate),
function(v) {
c <- spec$spec$calibrate[[v]]
d <- data.frame(x = names(c), Freq = as.numeric(c))
names(d) <- c(v, "Freq")
d
}
)
names(cal) <- names(spec$spec$calibrate)
storeFreqTables(cal)
}
dataDesign <<- unclass(x)
dataDesignName <<- sprintf(
"%s.%s",
name,
switch(x$spec$survey_type,
"survey" = "svy",
"replicate" = "repsvy"
)
)
# when design changed, update the object
invisible(createSurveyObject(reload = TRUE))
if (!missing(gui)) {
gui$dataNameWidget$updateWidget()
gui$menuBarWidget$defaultMenu()
}
},
createSurveyObject = function(reload = FALSE) {
if (!is.null(currentDesign$design) && !reload) {
return(currentDesign$design)
}
currentDesign <<- getDesign()
currentDesign$design
},
getDesign = function() {
dataDesign
},
storeFreqTables = function(tbls) {
freqtables <<- tbls
},
getFreqTables = function() {
freqtables
},
getCode = function(remove = TRUE) {
code <- attr(dataSet, "code")
if (remove) {
.dataSetChanged$block()
attr(dataSet, "code") <<- ""
.dataSetChanged$unblock()
}
code
},
setName = function(x) {
if (x == "") {
return()
}
oldname <<- name
## set the dataset's name
.dataSetChanged$block()
attr(dataSet, "name") <<- x
if (oldname != "") {
attr(dataSet, "code") <<- sprintf(".dataset <- %s", oldname)
}
.dataSetChanged$unblock()
name <<- x
},
getName = function() {
name
},
setDictionary = function(dict, apply = FALSE) {
# do this once, so it's easily available:
cn <- tolower(colnames(getData()))
# cn <- cn[cn %in% names(dict)]
dict <- dict[tolower(names(dict)) %in% cn]
dict_df <<- iNZightTools::as_tibble(dict, code_sep = "\n")
dictionary <<- unclass(dict)
if (!apply) {
return()
}
newdat <- try(
iNZightTools::apply_dictionary(getData(), dict),
silent = TRUE
)
if (inherits(newdat, "try-error")) {
return()
}
attr(newdat, "name") <- name
setData(newdat)
}
)
)
iNZPlotSettings <- setRefClass(
"iNZPlotSettings",
properties(
fields = list(
settings = "list",
defaultSettings = "list"
),
prototype = list(
settings = list(),
defaultSettings = list()
)
),
contains = "PropertySet", ## need this to add observer to object
methods = list(
initialize = function(settings = NULL, preferences = list()) {
defaultSettings <<- unclass(
getOption(
"inzight.default.par",
default = iNZightPlots:::inzpar()
)
)
pref_names <- c("gg_theme")
if (any(pref_names %in% names(preferences))) {
prefs <- preferences[names(preferences) %in% pref_names]
if (length(prefs)) {
defaultSettings <<- modifyList(defaultSettings, prefs, keep.null = TRUE)
}
}
if (!is.null(settings)) {
settings <<- settings
} else {
settings <<- defaultSettings
}
},
getSettings = function() {
settings
},
## change the plot settings
## reset: if TRUE, the default plot settings are loaded
## for the additions to the plot
setSettings = function(setList, reset = FALSE) {
## changing x or y? reset the limits
if (!is.null(setList$x) || !is.null(setList$y)) {
settings$xlim <<- NULL
settings$ylim <<- NULL
}
if (reset) {
setList <- modifyList(setList, defaultSettings, keep.null = TRUE)
}
settings <<- modifyList(settings, setList, keep.null = TRUE)
defaultSettings <<- modifyList(
defaultSettings,
extractDefaults(settings),
keep.null = TRUE
)
},
## reset the plot settings (except the data fields)
resetSettings = function() {
setSettings(unclass(iNZightPlots:::inzpar()))
},
## extract a sub-list of a settings list
## than can be used to merge with defaultSettings
extractDefaults = function(theSettings) {
defaultFields <- names(defaultSettings)
forget <- c("plottype", "xlim", "ylim")
defaultFields <- defaultFields[!defaultFields %in% forget]
theSettings[defaultFields]
},
addSettingsObserver = function(FUN, ...) {
.self$settingsChanged$connect(FUN, ...)
},
addObjObserver = function(FUN, ...) {
.self$changed$connect(FUN, ...)
},
removeSignals = function() {
for (i in seq_along(listeners(settingsChanged))) {
settingsChanged$disconnect(1)
}
for (i in seq_along(listeners(.changed))) {
.changed$disconnect(1)
}
}
)
)
iNZDocument <- setRefClass(
"iNZDocument",
fields = list(
dataModel = "iNZDataModel",
plotSettings = "iNZPlotSettings"
),
methods = list(
initialize = function(data = NULL, settings = NULL, preferences = list()) {
## set data name (default = "data")
if (!is.null(data) && is.null(attr(data, "name", exact = TRUE))) {
attr(data, "name") <- deparse(substitute(data))
}
initFields(
dataModel = iNZDataModel$new(data),
plotSettings = iNZPlotSettings$new(settings, preferences)
)
},
getModel = function() {
dataModel
},
getPlotSettings = function() {
plotSettings
},
getData = function(lazy = FALSE) {
dataModel$getData(lazy)
},
getSettings = function() {
plotSettings$getSettings()
},
setSettings = function(setList, reset = FALSE) {
plotSettings$setSettings(setList, reset)
},
setDictionary = function(dict, apply = TRUE) {
dataModel$setDictionary(dict, apply = apply)
},
## update the settings to take in current x,y values
## from the dataset
updateSettings = function() {
settings <- plotSettings$settings
if (!is.null(settings$x) && !is.null(settings$varnames$x)) {
settings$x <- as.name(settings$varnames$x)
}
if (!is.null(settings$y) && !is.null(settings$varnames$y)) {
settings$y <- as.name(settings$varnames$y)
}
setSettings(settings)
},
getCode = function() {
dataModel$getCode()
},
addDataObserver = function(FUN, ...) {
dataModel$addDataObserver(FUN, ...)
},
addSettingsObserver = function(FUN, ...) {
plotSettings$addSettingsObserver(FUN, ...)
},
addDataObjObserver = function(FUN, ...) {
dataModel$addObjObserver(FUN, ...)
},
addSettingsObjObserver = function(FUN, ...) {
plotSettings$addObjObserver(FUN, ...)
},
removeSignals = function() {
dataModel$removeSignals()
plotSettings$removeSignals()
}
)
)
iNZDataNameWidget <- setRefClass(
"iNZDataNameWidget",
fields = list(
GUI = "ANY", ## the iNZight GUI object
import_button = "ANY",
datName = "ANY", ## the string for the data set name
widget = "ANY",
nameLabel = "ANY"
),
methods = list(
initialize = function(gui) {
initFields(
GUI = gui,
datName = "No data loaded"
)
widget <<- ggroup()
addSpace(widget, 5)
add(widget, glabel("Dataset: "))
# nameLabel <<- glabel(.self$datName, expand = TRUE, anchor = c(-1, 0))
# font(nameLabel) <<- list(weight = "bold")
nameLabel <<- gcombobox(.self$datName,
handler = function(h, ...) {
## prevent code writing ...
pset <- GUI$getActiveDoc()$getSettings()
GUI$rhistory$disabled <<- TRUE
GUI$activeDoc <<- svalue(h$obj, index = TRUE)
GUI$rhistory$disabled <<- FALSE
GUI$ctrlWidget$setState(pset)
}
)
# add(widget, nameLabel, expand = TRUE)
import_button <<- gbutton("Import data ...",
handler = function(h, ...) iNZImportWin$new(gui)
)
import_button$set_icon("gw-file")
add(widget, import_button, expand = TRUE)
updateWidget()
},
updateWidget = function() {
dataSet <- GUI$getActiveData(lazy = TRUE)
if (is.null(dataSet) || names(dataSet)[1] == "empty") {
datName <<- "No data loaded"
if (identical(widget$children[[2]], nameLabel)) {
widget$remove_child(nameLabel)
add(widget, import_button, expand = TRUE)
}
} else {
datName <<- attr(dataSet, "name", exact = TRUE)
if (identical(widget$children[[2]], import_button)) {
widget$remove_child(import_button)
add(widget, nameLabel, expand = TRUE)
}
}
names <- sapply(
GUI$iNZDocuments,
function(d) {
n <- d$getModel()$getName()
if (!is.null(d$getModel()$getDesign())) {
n <- sprintf(
"%s (survey design)",
d$getModel()$dataDesignName
)
}
n
}
)
blockHandlers(nameLabel)
# svalue(nameLabel) <<- datName
nameLabel$set_items(names)
svalue(nameLabel, index = TRUE) <<- GUI$activeDoc
unblockHandlers(nameLabel)
}
)
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.