Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
1111e5e
commit f137021
Showing
21 changed files
with
561 additions
and
341 deletions.
There are no files selected for viewing
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,17 +1,18 @@ | ||
| Package: RcmdrPlugin.pointG | ||
| Type: Package | ||
| Title: Rcmdr Graphical POINT of view for questionnaire data Plug-In | ||
| Version: 0.1 | ||
| Date: 2011-07-28 | ||
| Version: 0.2.1 | ||
| Date: 2012-02-14 | ||
| Author: Stephane Champely <champely@univ-lyon1.fr> | ||
| Maintainer: Stephane Champely <champely@univ-lyon1.fr> | ||
| Depends: Rcmdr (>= 1.4-0), tcltk, MASS, lattice, qgraph, VIM, maps, | ||
| YaleToolkit, ade4, effects, RColorBrewer,Hmisc, car | ||
| Suggests: rgl | ||
| Description: This package provides an Rcmdr "plug-in" to analyze questionnaire data. | ||
| Description: This package provides an Rcmdr "plug-in" to analyze | ||
| questionnaire data. | ||
| License: GPL (>= 2) | ||
| Models: | ||
| Encoding: latin1 | ||
| Repository: CRAN | ||
| Date/Publication: 2011-12-03 15:14:06 | ||
| Packaged: 2011-12-03 11:06:32 UTC; champely | ||
| Date/Publication: 2012-02-17 07:38:35 | ||
| Packaged: 2012-02-17 04:51:05 UTC; champely |
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
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,22 @@ | ||
| # Default NAMESPACE created by R | ||
| # Remove the previous line if you edit this file | ||
|
|
||
| # Export all names | ||
| exportPattern(".") | ||
|
|
||
| # Import all packages listed as Imports or Depends | ||
| import( | ||
| Rcmdr, | ||
| tcltk, | ||
| MASS, | ||
| lattice, | ||
| qgraph, | ||
| VIM, | ||
| maps, | ||
| YaleToolkit, | ||
| ade4, | ||
| effects, | ||
| RColorBrewer, | ||
| Hmisc, | ||
| car | ||
| ) |
This file was deleted.
Oops, something went wrong.
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,27 @@ | ||
| Yule1<- | ||
| function (df, levX, varX, varY) | ||
| { | ||
| X <- df[, varX] | ||
| Y <- df[, varY] | ||
| CT <- table(X, Y) | ||
| sumX <- apply(CT, 1, sum) | ||
| sumY <- apply(CT, 2, sum) | ||
| sumCT <- sum(CT) | ||
| levY <- levels(Y) | ||
| J <- length(levY) | ||
| result <- matrix(0, nrow = J, ncol = 4) | ||
| for (j in 1:J) { | ||
| a <- CT[levX, levY[j]] | ||
| b <- sumX[levX] - a | ||
| c <- sumY[levY[j]] - a | ||
| d <- sumCT - a - b - c | ||
| result[j, 1] <- a | ||
| Q <- (a * d - b * c)/(a * d + b * c) | ||
| result[j, 2] <- Q | ||
| result[j, 3] <- (1 - Q^2) * sqrt(1/a + 1/b + 1/c + 1/d)/2 | ||
| result[j, 4] <- chisq.test(matrix(c(a, c, b, d), ncol = 2))$p.value | ||
| } | ||
| colnames(result) <- c("n", "Q", "se(Q)", "p") | ||
| rownames(result) <- paste(varY, levY, sep = "_") | ||
| result | ||
| } |
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,30 @@ | ||
| Yule2<- | ||
| function (df, levX, varX, varY) | ||
| { | ||
| X <- df[, varX] | ||
| Y <- df[, varY] | ||
| Ycut <- cut(Y, breaks = c(min(Y, na.rm = TRUE) - 1, mean(Y, | ||
| t = 0.2, na.rm = TRUE), max(Y, na.rm = TRUE)), label = c("Moins", | ||
| "Plus")) | ||
| CT <- table(X, Ycut) | ||
| sumX <- apply(CT, 1, sum) | ||
| sumY <- apply(CT, 2, sum) | ||
| sumCT <- sum(CT) | ||
| levY <- levels(Ycut) | ||
| J <- length(levY) | ||
| result <- matrix(0, nrow = J, ncol = 4) | ||
| for (j in 1:J) { | ||
| a <- CT[levX, levY[j]] | ||
| b <- sumX[levX] - a | ||
| c <- sumY[levY[j]] - a | ||
| d <- sumCT - a - b - c | ||
| result[j, 1] <- a | ||
| Q <- (a * d - b * c)/(a * d + b * c) | ||
| result[j, 2] <- Q | ||
| result[j, 3] <- (1 - Q^2) * sqrt(1/a + 1/b + 1/c + 1/d)/2 | ||
| result[j, 4] <- chisq.test(matrix(c(a, c, b, d), ncol = 2))$p.value | ||
| } | ||
| colnames(result) <- c("n", "Q", "se(Q)", "p") | ||
| rownames(result) <- paste(varY, levY, sep = "_") | ||
| result | ||
| } |
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,23 @@ | ||
| Yule3<- | ||
| function (df, levX, varX, varYYY) | ||
| { | ||
| L <- length(varYYY) | ||
| if (is.factor(df[, varYYY[1]])) { | ||
| T1 <- Yule1(df, levX, varX, varYYY[1]) | ||
| } | ||
| else { | ||
| T1 <- Yule2(df, levX, varX, varYYY[1]) | ||
| } | ||
| if (L > 1) { | ||
| for (l in 2:L) { | ||
| if (is.factor(df[, varYYY[l]])) { | ||
| T2 <- Yule1(df, levX, varX, varYYY[l]) | ||
| } | ||
| else { | ||
| T2 <- Yule2(df, levX, varX, varYYY[l]) | ||
| } | ||
| T1 <- rbind(T1, T2) | ||
| } | ||
| } | ||
| T1 | ||
| } |
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,17 @@ | ||
| Yule4<- | ||
| function (df, levX, varX, varYYY, alpha = 0.1) | ||
| { | ||
| T1 <- Yule3(df, levX, varX, varYYY) | ||
| T2 <- T1[T1[, 2] > 0, ] | ||
| T3 <- T2[order(T2[, 2]), ] | ||
| T4 <- T3[T3[, 4] < alpha, ] | ||
| L <- nrow(T4) | ||
| MIN <- min(0, T4[, 2] - 1.96 * T4[, 3]) | ||
| MAX <- max(1, T4[, 2] + 1.96 * T4[, 3]) | ||
| titre <- paste(varX, levX, sep = "=") | ||
| dotchart(T4[, 2], labels = rownames(T4), xlim = c(MIN, MAX), | ||
| main = titre) | ||
| abline(v = 0, lty = 2) | ||
| segments(T4[, 2] - 1.96 * T4[, 3], 1:L, T4[, 2] + 1.96 * | ||
| T4[, 3], 1:L) | ||
| } |
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,173 @@ | ||
| bbbisummarize0<- function () { | ||
| require("car") | ||
| defaults <- list(initial.x = NULL, initial.y = NULL, initial.jitterx = 0, initial.jittery = 0, | ||
| initial.logstringx = 0, initial.logstringy = 0, initial.log = 0, initial.box = 1, | ||
| initial.line = 1, initial.smooth = 1, initial.spread = 1, initial.span = 50, | ||
| initial.subset = gettextRcmdr ("<all valid cases>"), initial.ylab = gettextRcmdr ("<auto>"), | ||
| initial.xlab = gettextRcmdr("<auto>"), initial.pch = gettextRcmdr("<auto>"), | ||
| initial.cexValue = 1, initial.cex.axisValue = 1, initial.cex.labValue = 1, initialGroup=NULL, initial.lines.by.group=1) | ||
| dialog.values <- getDialog("scatterPlot", defaults) | ||
| initial.group <- dialog.values$initial.group | ||
| .linesByGroup <- if (dialog.values$initial.lines.by.group == 1) TRUE else FALSE | ||
| .groups <- if (is.null(initial.group)) FALSE else initial.group | ||
| initializeDialog(title = gettextRcmdr("Statistiques croisees en saucisson")) | ||
| .numeric <- Numeric() | ||
| variablesFrame <- tkframe(top) | ||
| xBox <- variableListBox(variablesFrame, Variables(), title = gettextRcmdr("Explicative (une seule)")) | ||
| yBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple",title = gettextRcmdr("A expliquer (plusieurs)")) | ||
|
|
||
| optionsParFrame <- tkframe(top) | ||
| checkBoxes(window = optionsParFrame, frame = "optionsFrame", | ||
| boxes = c("identify", "jitterX", "jitterY", "logX", "logY", | ||
| "boxplots", "lsLine", "smoothLine", "spread"), initialValues = c(dialog.values$initial.log, | ||
| dialog.values$initial.jitterx, dialog.values$initial.jittery, | ||
| dialog.values$initial.logstringx, dialog.values$initial.logstringy, | ||
| dialog.values$initial.box, dialog.values$initial.line, dialog.values$initial.smooth, | ||
| dialog.values$initial.spread),labels = gettextRcmdr(c("Identify points", | ||
| "Jitter x-variable", "Jitter y-variable", "Log x-axis", | ||
| "Log y-axis", "Marginal boxplots", "Least-squares line", | ||
| "Smooth line", "Show spread")), title = "Options") | ||
| sliderValue <- tclVar(dialog.values$initial.span) | ||
| slider <- tkscale(optionsFrame, from = 0, to = 100, showvalue = TRUE, | ||
| variable = sliderValue, resolution = 5, orient = "horizontal") | ||
| subsetBox(subset.expression = dialog.values$initial.subset) | ||
| labelsFrame <- tkframe(top) | ||
| xlabVar <- tclVar(dialog.values$initial.xlab) | ||
| ylabVar <- tclVar(dialog.values$initial.ylab) | ||
| xlabFrame <- tkframe(labelsFrame) | ||
| xlabEntry <- ttkentry(xlabFrame, width = "25", textvariable = xlabVar) | ||
| xlabScroll <- ttkscrollbar(xlabFrame, orient = "horizontal", | ||
| command = function(...) tkxview(xlabEntry, ...)) | ||
| tkconfigure(xlabEntry, xscrollcommand = function(...) tkset(xlabScroll, | ||
| ...)) | ||
| tkgrid(labelRcmdr(xlabFrame, text = gettextRcmdr("x-axis label"), | ||
| fg = "blue"), sticky = "w") | ||
| tkgrid(xlabEntry, sticky = "w") | ||
| tkgrid(xlabScroll, sticky = "ew") | ||
| ylabFrame <- tkframe(labelsFrame) | ||
| ylabEntry <- ttkentry(ylabFrame, width = "25", textvariable = ylabVar) | ||
| ylabScroll <- ttkscrollbar(ylabFrame, orient = "horizontal", | ||
| command = function(...) tkxview(ylabEntry, ...)) | ||
| tkconfigure(ylabEntry, xscrollcommand = function(...) tkset(ylabScroll, | ||
| ...)) | ||
| tkgrid(labelRcmdr(ylabFrame, text = gettextRcmdr("y-axis label"), | ||
| fg = "blue"), sticky = "w") | ||
| tkgrid(ylabEntry, sticky = "w") | ||
| tkgrid(ylabScroll, sticky = "ew") | ||
| tkgrid(xlabFrame, labelRcmdr(labelsFrame, text = " "), | ||
| ylabFrame, sticky = "w") | ||
| parFrame <- tkframe(optionsParFrame) | ||
| pchVar <- tclVar(dialog.values$initial.pch) | ||
| pchEntry <- ttkentry(parFrame, width = 25, textvariable = pchVar) | ||
| cexValue <- tclVar(dialog.values$initial.cexValue) | ||
| cex.axisValue <- tclVar(dialog.values$initial.cex.axisValue) | ||
| cex.labValue <- tclVar(dialog.values$initial.cex.labValue) | ||
| cexSlider <- tkscale(parFrame, from = 0.5, to = 2.5, showvalue = TRUE, | ||
| variable = cexValue, resolution = 0.1, orient = "horizontal") | ||
| cex.axisSlider <- tkscale(parFrame, from = 0.5, to = 2.5, | ||
| showvalue = TRUE, variable = cex.axisValue, resolution = 0.1, | ||
| orient = "horizontal") | ||
| cex.labSlider <- tkscale(parFrame, from = 0.5, to = 2.5, | ||
| showvalue = TRUE, variable = cex.labValue, resolution = 0.1, | ||
| orient = "horizontal") | ||
| onOK <- function(){ | ||
| x <- getSelection(xBox) | ||
| y <- getSelection(yBox) | ||
| closeDialog() | ||
| if (length(x) == 0 || length(y) == 0){ | ||
| errorCondition(recall=bbbisummarize0, message=gettextRcmdr("You must select two variables")) | ||
| return() | ||
| } | ||
| if (length(x) > 1){ | ||
| errorCondition(recall=bbbisummarize0, message=gettextRcmdr("Une seule variable explicative")) | ||
| return() | ||
| } | ||
| if (length(y) <2){ | ||
| errorCondition(recall=bbbisummarize0, message=gettextRcmdr("Une tranche contient au moins deux variables")) | ||
| return() | ||
| } | ||
|
|
||
|
|
||
| .activeDataSet <- ActiveDataSet() | ||
| jitter <- if ("1" == tclvalue(jitterXVariable) && "1" == tclvalue(jitterYVariable)) ", jitter=list(x=1, y=1)" | ||
| else if ("1" == tclvalue(jitterXVariable)) ", jitter=list(x=1)" | ||
| else if ("1" == tclvalue(jitterYVariable)) ", jitter=list(y=1)" | ||
| else "" | ||
| logstring <- "" | ||
| if ("1" == tclvalue(logXVariable)) logstring <- paste(logstring, "x", sep="") | ||
| if ("1" == tclvalue(logYVariable)) logstring <- paste(logstring, "y", sep="") | ||
| log <- if(logstring != "") paste(', log="', logstring, '"', sep="") else "" | ||
| if("1" == tclvalue(identifyVariable)){ | ||
| RcmdrTkmessageBox(title="Identify Points", | ||
| message=paste(gettextRcmdr("Use left mouse button to identify points,\n"), | ||
| gettextRcmdr(if (MacOSXP()) "esc key to exit." else "right button to exit."), sep=""), | ||
| icon="info", type="ok") | ||
| idtext <- ', id.method="identify"' | ||
| } | ||
| else idtext <- "" | ||
| box <- if ("1" == tclvalue(boxplotsVariable)) "'xy'" else "FALSE" | ||
| line <- if("1" == tclvalue(lsLineVariable)) "lm" else "FALSE" | ||
| smooth <- as.character("1" == tclvalue(smoothLineVariable)) | ||
| spread <- as.character("1" == tclvalue(spreadVariable)) | ||
| span <- as.numeric(tclvalue(sliderValue)) | ||
| subset <- tclvalue(subsetVariable) | ||
| subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) "" | ||
| else paste(", subset=", subset, sep="") | ||
| xlab <- trim.blanks(tclvalue(xlabVar)) | ||
| xlab <- if(xlab == gettextRcmdr("<auto>")) "" else paste(', xlab="', xlab, '"', sep="") | ||
| ylab <- trim.blanks(tclvalue(ylabVar)) | ||
| ylab <- if(ylab == gettextRcmdr("<auto>")) "" else paste(', ylab="', ylab, '"', sep="") | ||
| cex <- as.numeric(tclvalue(cexValue)) | ||
| cex <- if(cex == 1) "" else paste(', cex=', cex, sep="") | ||
| cex.axis <- as.numeric(tclvalue(cex.axisValue)) | ||
| cex.axis <- if(cex.axis == 1) "" else paste(', cex.axis=', cex.axis, sep="") | ||
| cex.lab <- as.numeric(tclvalue(cex.labValue)) | ||
| cex.lab <- if(cex.lab == 1) "" else paste(', cex.lab=', cex.lab, sep="") | ||
| pch <- gsub(" ", ",", tclvalue(pchVar)) | ||
| if ("" == pch) { | ||
| errorCondition(recall=scatterPlot, message=gettextRcmdr("No plotting characters.")) | ||
| return() | ||
| } | ||
| pch <- if(trim.blanks(pch) == gettextRcmdr("<auto>")) "" else paste(", pch=c(", pch, ")", sep="") | ||
|
|
||
| selectVars <- paste(", select=c(", x, ",", paste(y, collapse = ","), | ||
| ")", sep = "") | ||
| newn <- "D1" | ||
| command <- paste(newn, " <- subset(", ActiveDataSet(), | ||
| selectVars, ")", sep = "") | ||
| logger(command) | ||
| result <- justDoIt(command) | ||
| print(paste("Variable explicative",x,sep=" : ")) | ||
| print(bisummarize0(newn)) | ||
| if (class(result)[1] != "try-error") | ||
| tkfocus(CommanderWindow()) | ||
| activateMenus() | ||
| tkfocus(CommanderWindow()) } | ||
| groupsBox(scatterPlot, plotLinesByGroup = TRUE, initialGroup=initial.group, initialLinesByGroup=dialog.values$initial.lines.by.group, | ||
| initialLabel=if (is.null(initial.group)) gettextRcmdr("Plot by groups") else paste(gettextRcmdr("Plot by:"), initial.group)) | ||
| OKCancelHelp(helpSubject = " bivariate0") | ||
| tkgrid(getFrame(xBox), getFrame(yBox), sticky = "nw") | ||
| tkgrid(variablesFrame, sticky = "w") | ||
| tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("Span for smooth")), | ||
| slider, sticky = "w") | ||
| tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Plotting Parameters"), | ||
| fg = "blue"), sticky = "w") | ||
| tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Plotting characters")), | ||
| pchEntry, stick = "w") | ||
| # tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Point size")), | ||
| # cexSlider, sticky = "w") | ||
| #tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Axis text size")), | ||
| # cex.axisSlider, sticky = "w") | ||
| #tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Axis-labels text size")), | ||
| # cex.labSlider, sticky = "w") | ||
| tkgrid(optionsFrame, parFrame, sticky = "nw") | ||
| #tkgrid(optionsParFrame, sticky = "w") | ||
| #tkgrid(labelsFrame, sticky = "w") | ||
| #tkgrid(subsetFrame, sticky = "w") | ||
| #tkgrid(groupsFrame, sticky = "w") | ||
| tkgrid(labelRcmdr(top, text = " ")) | ||
| tkgrid(buttonsFrame, columnspan = 2, sticky = "w") | ||
| dialogSuffix(rows = 8, columns = 2) | ||
| } | ||
|
|
||
|
|
Oops, something went wrong.