Commit b21c5202 authored by Yong Liu's avatar Yong Liu

Refs #5751

parent 25e326fd
......@@ -5246,6 +5246,137 @@ compareDataExport <- function(comparedScript, len, ...){
}
}
linearRegression <- function(sdcObject, step, ...) {
if(existd("sdcObject") == FALSE){
gmessage("There is no dataset loaded for Comparison!", "No Dataset!",icon="warning")
} else{
lrDialog <- gwindow("Linear Regression", parent=window, width=600, height=400)
lTOr <- function(h, left, right, ...) {
if( length(h)>0 ) {
if( length(right[])==1 ) {
if( is.na(right[]) ) {
right[,] <- data.frame(vars=h, stringsAsFactors=FALSE)
} else {
right[,] <- data.frame(vars=c(right[], h), stringsAsFactors=FALSE)
}
} else {
right[,] <- data.frame(vars=c(right[], h), stringsAsFactors=FALSE)
}
if( length(h)==length(left[]) ) {
left[,] <- data.frame(vars=character(0), stringsAsFactors=FALSE)
} else {
xtmp <- c()
for( i in 1:length(left[]) ) {
for( j in 1:length(h) ) {
if( left[][i]==h[j] ) {
xtmp <- c(xtmp, i)
}
}
}
left[,] <- data.frame(vars=left[-xtmp], stringsAsFactors=FALSE)
}
}
}
rTOl <- function(h, left, right,...) {
if( length(h)>0 ) {
if( length(left[])==1 ) {
if( is.na(left[]) ) {
left[,] <- data.frame(vars=h, stringsAsFactors=FALSE)
} else {
left[,] <- data.frame(vars=c(left[], h), stringsAsFactors=FALSE)
}
} else {
left[,] <- data.frame(vars=c(left[], h), stringsAsFactors=FALSE)
}
if( length(h)==length(right[]) ) {
right[,] <- data.frame(vars=character(0), stringsAsFactors=FALSE)
} else {
xtmp <- c()
for( i in 1:length(right[]) ) {
for( j in 1:length(h) ) {
if( right[][i]==h[j] ) {
xtmp <- c(xtmp, i)
}
}
}
right[,] <- data.frame(vars=right[-xtmp], stringsAsFactors=FALSE)
}
}
}
nb <- gnotebook(container=lrDialog, closebuttons=FALSE)
#Main
p1_windowGroup = ggroup(container=nb, horizontal=FALSE,label="Function")
#Help
t <- gtext(container=nb, label="Help ", expand=TRUE)
l <- .findHelpPage("lm", "stats")
x <- l$x
.insertHelpPage(t, x)
svalue(nb) <- 1
mainframe = gframe('', container=p1_windowGroup, horizontal=TRUE)
tmp = gframe('<span weight="bold" size="medium">Dependent Variable Selection</span>',
container=mainframe, horizontal=TRUE,markup=TRUE)
sdcObject = ActiveSdcObject()
data <- extractManipData(sdcObject)
if(!is.null(sdcObject@deletedVars)) {
data <- data[!names(data) %in% sdcObject@deletedVars]
}
varTab = gtable(data.frame(vars=names(data), stringsAsFactors=FALSE), multiple=TRUE)
size(varTab) <- c(120,200)
add(tmp, varTab)
btmp = ggroup(container=tmp, horizontal=FALSE)
addSpring(btmp)
b1 <- gbutton(">>", container=btmp, handler=function(h,...) { lTOr(svalue(varTab), varTab, selTab) })
b2 <- gbutton("<<", container=btmp, handler=function(h,...) { rTOl(svalue(selTab), varTab, selTab) })
addSpring(btmp)
selTab = gtable(data.frame(vars=character(0), stringsAsFactors=FALSE), multiple=TRUE)
size(selTab) <- c(120,200)
add(tmp, selTab)
tmp = gframe('<span weight="bold" size="medium">Independent Variable Selection</span>',
container=mainframe,markup=TRUE)
keyVars <- ActiveSdcVarsStr()
sTab = gtable(data.frame(vars=c(keyVars, ActiveSdcVarsStr("numVars")), stringsAsFactors=FALSE), multiple=TRUE)
size(sTab) <- c(120,200)
add(tmp, sTab)
btmp = ggroup(container=tmp, horizontal=FALSE)
addSpring(btmp)
b1 <- gbutton(">>", container=btmp, handler=function(h,...) { lTOr(svalue(sTab), sTab, selTab1) })
b2 <- gbutton("<<", container=btmp, handler=function(h,...) { rTOl(svalue(selTab1), sTab, selTab1) })
addSpring(btmp)
selTab1 = gtable(data.frame(vars=character(0), stringsAsFactors=FALSE), multiple=TRUE)
size(selTab1) <- c(120,200)
add(tmp, selTab1)
gseparator(container=p1_windowGroup)
nm2_windowButtonGroup = ggroup(container=p1_windowGroup)
addSpring(nm2_windowButtonGroup)
gbutton("Caculate", container=nm2_windowButtonGroup,
handler=function(h,...) {
if( (length(selTab[])<1 | any(is.na(selTab[]))) || (length(selTab1[])<1 | any(is.na(selTab1[])))) {
gmessage("You need to select at least 1 variable!", title="Information", icon="info", parent=lrDialog)
} else {
tryCatch({
form = paste(paste(selTab[], collapse = "+"), "~", paste(selTab1[], collapse = "+"), sep=" ")
orig_lm = lm(formula = as.formula(form), data =sdcObject@origData)
curr_lm = lm(formula = as.formula(form), data =data)
orig_R2 = summary(orig_lm)$r.squared
curr_R2 = summary(curr_lm)$r.squared
svalue(outputlabel) <- paste("The goodness of fit ratio is:\norig_R2 : curr_R2 = ", round(orig_R2/curr_R2,2), ":1", sep="")}
,
error=function(e){
svalue(outputlabel) <- paste("error:\n", e, "")
})
}
})
gbutton("Close ", container=nm2_windowButtonGroup, handler=function(h,...) { dispose(lrDialog) })
gseparator(container=p1_windowGroup)
outputGroup = ggroup(container=p1_windowGroup, expand=TRUE)
outputlabel = glabel("", container=outputGroup)
}
}
compareSummaries <- function(sdcObject, step, ...) {
if(existd("sdcObject") == FALSE){
gmessage("There is no dataset loaded for Comparison!", "No Dataset!",icon="warning")
......@@ -5347,7 +5478,9 @@ compareDataExport <- function(comparedScript, len, ...){
mbar$"Disclosure Risks and Data Utility"$"Categorical Key Variables"$"Population Frequencies and Individual Risks"$handler= function(...) populateFreqandRisk()
mbar$"Disclosure Risks and Data Utility"$"Categorical Key Variables"$"L-diversity"$handler= function(...) ldiv1()
mbar$"Disclosure Risks and Data Utility"$"Categorical Key Variables"$"PRAM output"$handler = viewpram1
mbar$"Disclosure Risks and Data Utility"$"Categorical Key Variables"$"Linear Regression"$handler= function(...) linearRegression()
mbar$"Disclosure Risks and Data Utility"$"Continuous Key Variables"$handler= function(...)helpR("localSuppression")
mbar$"Disclosure Risks and Data Utility"$"Linear Regression"$handler= function(...) linearRegression()
mbar$"Reports and Logs"$"Generate Report"$handler = exportReport
# mbar$Script$"Run"$handler = runScript
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment