diag_mask <- (row(corm) != col(corm))&(row(corm) %in% indm)&(col(corm) %in% indm1)
# Maximaler Wert oberhalb der Hauptdiagonale
max_val <- max(abs(corm[diag_mask]))
# Position(en) des maximalen Werts: das 1. auftretende Paar
pos<- unname((which(abs(corm) == max_val & diag_mask, arr.ind = TRUE))[1,])
lalg <- c(lalg,list(pos))
pos0<- which(vmeng==pos[2]) #Vereinigung Mengen pos[1] mit pos[2]
vmeng[pos0]<- pos[1]
indm<- setdiff(indm,pos[2]) #Aktualisierung indm,indm1
indm1<- setdiff(indm1,pos)
##Neuberechnung Werte in corm
pos1<- which(vmeng == pos[1])  #Mengenelemente von pos[1]
for (j in indm1){
ll<- kendr(daten[,pos1],daten[,j],out=1)  #Liste der Ergebnisse
corm[pos[1],j]<- max(sapply(ll, function(x) abs(x$dcoeff)))  #maximaler direktionaler Koeff.
}
indm1
vmeng
length(unique(vmeng))
# Maske für die Hauptdiagonale Spaltennr>Zeilennr
diag_mask <- (row(corm) != col(corm))&(row(corm) %in% indm)&(col(corm) %in% indm1)
# Maximaler Wert oberhalb der Hauptdiagonale
max_val <- max(abs(corm[diag_mask]))
# Position(en) des maximalen Werts: das 1. auftretende Paar
pos<- unname((which(abs(corm) == max_val & diag_mask, arr.ind = TRUE))[1,])
lalg <- c(lalg,list(pos))
pos0<- which(vmeng==pos[2]) #Vereinigung Mengen pos[1] mit pos[2]
vmeng[pos0]<- pos[1]
indm<- setdiff(indm,pos[2]) #Aktualisierung indm,indm1
indm1<- setdiff(indm1,pos)
##Neuberechnung Werte in corm
pos1<- which(vmeng == pos[1])  #Mengenelemente von pos[1]
for (j in indm1){
ll<- kendr(daten[,pos1],daten[,j],out=1)  #Liste der Ergebnisse
corm[pos[1],j]<- max(sapply(ll, function(x) abs(x$dcoeff)))  #maximaler direktionaler Koeff.
}
indm1
diag_mask <- (row(corm) != col(corm))&(row(corm) %in% indm)&(col(corm) %in% indm1)
# Maximaler Wert oberhalb der Hauptdiagonale
max_val <- max(abs(corm[diag_mask]))
# Position(en) des maximalen Werts: das 1. auftretende Paar
pos<- unname((which(abs(corm) == max_val & diag_mask, arr.ind = TRUE))[1,])
lalg <- c(lalg,list(pos))
pos
lalg
vmeng
name(vmeng)
names(vmeng)
names(vmeng)<- 1:k
vmeng
indm1
pos0<- which(vmeng==pos[2]) #Vereinigung Mengen pos[1] mit pos[2]
vmeng[pos0]<- pos[1]
indm<- setdiff(indm,pos[2]) #Aktualisierung indm,indm1
indm1<- setdiff(indm1,pos)
indm1
is.null(indm1)
is.na(indm1)
indm
pos
vmeng
#######Algorithmus
corm<- cor(daten,method="kendall") #Korrelationsmatrix
indm<- 1:k #Indexmenge
indm1<- 1:k #Indexmenge der Einzelelemente
lalg<- list()  #Liste zum Algorithmus
vmeng<- 1:k #Vektor der Mengenzuordnung, gibt zu jeder Var. die Mengennr. an
repeat{
# Maske für die Hauptdiagonale Spaltennr>Zeilennr
diag_mask <- (row(corm) != col(corm))&(row(corm) %in% indm)&(col(corm) %in% indm1)
# Maximaler Wert oberhalb der Hauptdiagonale
max_val <- max(abs(corm[diag_mask]))
# Position(en) des maximalen Werts: das 1. auftretende Paar
pos<- unname((which(abs(corm) == max_val & diag_mask, arr.ind = TRUE))[1,])
lalg <- c(lalg,list(pos))
pos0<- which(vmeng==pos[2]) #Vereinigung Mengen pos[1] mit pos[2]
vmeng[pos0]<- pos[1]
indm<- setdiff(indm,pos[2]) #Aktualisierung indm,indm1
if (length(indm1)==1) {break}
indm1<- setdiff(indm1,pos)
##Neuberechnung Werte in corm
pos1<- which(vmeng == pos[1])  #Mengenelemente von pos[1]
for (j in indm1){
ll<- kendr(daten[,pos1],daten[,j],out=1)  #Liste der Ergebnisse
corm[pos[1],j]<- max(sapply(ll, function(x) abs(x$dcoeff)))  #maximaler direktionaler Koeff.
}
} #En
vmeng
lalg
library(depcoeff)
kendr1<-function(x,y,direction=NULL,out=0){
require(copula)
nn<- length(y)
d<- length(x[1,])
msr<- -10.0 #maximum coefficient
if (is.null(direction)) { ka<-(2^(d-1)-1)} else {ka<- 0}
ret<- list()
for (k in ka:0){
u<- as.matrix(x)
if (ka>0){  #all directions
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
} else {  #  one direction
u<- x
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
v<- as.matrix(cbind(u,y))
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
if (out==1){   # output of all coefficients
if (A==0.0) {ret[[k+1]]<- list(dcoeff="not defined",dir=direction)
}else{ret[[k+1]]<- list(dcoeff=2*B/A-1.0,dir=direction)}  #An,Bn,
}else{
if (A!=0.0){  ## reduced output of the largest absolut value
h<- 2*B/A-1.0
if (abs(h)>msr) {
msr<- abs(h)
ret[[1]]<- list(dcoeff=h,dir=direction)
}
}
}
}
return(ret)
}
microbenchmark(
kendr(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
#########
library(microbenchmark)
microbenchmark(
kendr(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
microbenchmark(
kendr1(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
u
x<- daten[,c(1,2,3)]
y<- daten[,6]
out<- 0
require(copula)
nn<- length(y)
d<- length(x[1,])
msr<- -10.0 #
if (is.null(direction)) { ka<-(2^(d-1)-1)} else {ka<- 0}
direction<- NULL
if (is.null(direction)) { ka<-(2^(d-1)-1)} else {ka<- 0}
ka
ret<- list()
k<- ka
u<- as.matrix(x)
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
direction
u
v<- as.matrix(cbind(u,y))
v
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
A
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
B
if (A!=0.0){  ## reduced output of the largest absolut value
h<- 2*B/A-1.0
if (abs(h)>msr) {
msr<- abs(h)
ret[[1]]<- list(dcoeff=h,dir=direction)
}
}
msr
k<- ka-1
u<- as.matrix(x)
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
u
v<- as.matrix(cbind(u,y))
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
for (k in ka:0){
u<- as.matrix(x)
if (ka>0){  #all directions
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
} else {  #  one direction
u<- x
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
v<- as.matrix(cbind(u,y))
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
if (out==1){   # output of all coefficients
if (A==0.0) {ret[[k+1]]<- list(dcoeff="not defined",dir=direction)
}else{ret[[k+1]]<- list(dcoeff=2*B/A-1.0,dir=direction)}  #An,Bn,
}else{
if (A!=0.0){  ## reduced output of the largest absolut value
h<- 2*B/A-1.0
if (abs(h)>msr) {
msr<- abs(h)
ret[[1]]<- list(dcoeff=h,dir=direction)
}
}
}
}
k
u<- as.matrix(x)
if (ka>0){  #all directions
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
} else {  #  one direction
u<- x
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
v<- as.matrix(cbind(u,y))
u
v
k<- 0
u<- as.matrix(x)
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
direction
if (k!=ka)  { # direction does not consist of only ones
sel<- (direction<0)
u[,sel]<- -x[,sel]
}
sel
u
x
x[,sel]
u
u<- as.matrix(x)
u[,sel]
x[,sel]
u[,sel]<- -x[,sel]
u
k
u[,sel]<- -u[,sel]
u[,sel,drop=F]<- -u[,sel,drop=F]
# Prüfe die Ausgangssituation
class(x)
dim(x)
class(u)
dim(u)
# Prüfe sel
direction <- c(1, -1, -1)
sel <- (direction < 0)
print(sel)
sum(sel)  # Wie viele TRUE?
# Prüfe was u[, sel] ergibt
print(dim(u[, sel, drop = FALSE]))
u<- as.matrix(x)
# Prüfe die Ausgangssituation
class(x)
dim(x)
class(u)
dim(u)
# Prüfe sel
direction <- c(1, -1, -1)
sel <- (direction < 0)
print(sel)
sum(sel)  # Wie viele TRUE?
# Prüfe was u[, sel] ergibt
print(dim(u[, sel, drop = FALSE]))
print(class(u[, sel, drop = FALSE]))
# Versuche es auch so:
print(str(u))
temp <- -u[, sel, drop = FALSE]
u[, sel] <- temp
u
u<- as.matrix(x)
u[, which(sel)] <- -u[, which(sel)]
u
u<- as.matrix(x)
u[, c(2, 3)] <- -u[, c(2, 3)]
u
kendr1<-function(x,y,direction=NULL,out=0){
require(copula)
nn<- length(y)
d<- length(x[1,])
msr<- -10.0 #maximum coefficient
if (is.null(direction)) { ka<-(2^(d-1)-1)} else {ka<- 0}
ret<- list()
for (k in ka:0){
u<- as.matrix(x)
if (ka>0){  #all directions
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- (direction<0)
u[,which(sel)]<- -u[,which(sel)]
}
} else {  #  one direction
u<- x
sel<- (direction<0)
u[,which(sel)]<- -u[,which(sel)]
}
v<- as.matrix(cbind(u,y))
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
if (out==1){   # output of all coefficients
if (A==0.0) {ret[[k+1]]<- list(dcoeff="not defined",dir=direction)
}else{ret[[k+1]]<- list(dcoeff=2*B/A-1.0,dir=direction)}  #An,Bn,
}else{
if (A!=0.0){  ## reduced output of the largest absolut value
h<- 2*B/A-1.0
if (abs(h)>msr) {
msr<- abs(h)
ret[[1]]<- list(dcoeff=h,dir=direction)
}
}
}
}
return(ret)
}
microbenchmark(
kendr1(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
microbenchmark(
kendr(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
kendr1<-function(x,y,direction=NULL,out=0){
require(copula)
nn<- length(y)
d<- length(x[1,])
msr<- -10.0 #maximum coefficient
if (is.null(direction)) { ka<-(2^(d-1)-1)} else {ka<- 0}
ret<- list()
uu<- as.matrix(x)
for (k in ka:0){
if (ka>0){  #all directions
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- which(direction<0)
sela<- setdiff(1:d,sel)
u[,sel]<- -uu[,sel]
u[,sela]<- -uu[,sela]
}else{ u<- uu}
} else {  #  one direction
u<- x
sel<- which(direction<0)
u[,sel]<- -u[,sel]
}
v<- cbind(u,y)
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
if (out==1){   # output of all coefficients
if (A==0.0) {ret[[k+1]]<- list(dcoeff="not defined",dir=direction)
}else{ret[[k+1]]<- list(dcoeff=2*B/A-1.0,dir=direction)}  #An,Bn,
}else{
if (A!=0.0){  ## reduced output of the largest absolut value
h<- 2*B/A-1.0
if (abs(h)>msr) {
msr<- abs(h)
ret[[1]]<- list(dcoeff=h,dir=direction)
}
}
}
}
return(ret)
}
microbenchmark(
kendr1(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
microbenchmark(
kendr(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
kendr(daten[,c(1,2,3)],daten[,6])
kendr1(daten[,c(1,2,3)],daten[,6])
d <- 3
direction <- c(1, -1, -1)
sel <- (direction < 0)
microbenchmark(
which_variant = {u <- as.matrix(x); u[, which(sel)] <- -u[, which(sel)]},
sweep_variant = {u <- as.matrix(x); u <- sweep(u, 2, direction, "*")},
times = 1000
)
uu<- as.matrix(x)
uu<- cbind(uu,-uu)
uu
direction
c(d+which(direction<0),which(direction>0))
kendr1<-function(x,y,direction=NULL,out=0){
require(copula)
nn<- length(y)
d<- length(x[1,])
msr<- -10.0 #maximum coefficient
if (is.null(direction)) { ka<-(2^(d-1)-1)} else {ka<- 0}
ret<- list()
uu<- as.matrix(x)
uu<- cbind(uu,-uu)
for (k in ka:0){
if (ka>0){  #all directions
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- c(d+which(direction<0),which(direction>0))#sel<- which(direction<0)
#sela<- setdiff(1:d,sel)
u<- uu[,sel] #u[,sel]<- -uu[,sel]
#u[,sela]<- -uu[,sela]
}else{ u<- uu}
} else {  #  one direction
u<- x
sel<- which(direction<0)
u[,sel]<- -u[,sel]
}
v<- cbind(u,y)
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
if (out==1){   # output of all coefficients
if (A==0.0) {ret[[k+1]]<- list(dcoeff="not defined",dir=direction)
}else{ret[[k+1]]<- list(dcoeff=2*B/A-1.0,dir=direction)}  #An,Bn,
}else{
if (A!=0.0){  ## reduced output of the largest absolut value
h<- 2*B/A-1.0
if (abs(h)>msr) {
msr<- abs(h)
ret[[1]]<- list(dcoeff=h,dir=direction)
}
}
}
}
return(ret)
}
microbenchmark(
kendr1(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
kendr1<-function(x,y,direction=NULL,out=0){
require(copula)
nn<- length(y)
d<- length(x[1,])
msr<- -10.0 #maximum coefficient
if (is.null(direction)) { ka<-(2^(d-1)-1)} else {ka<- 0}
ret<- list()
uu<- as.matrix(x)
u<- uu
for (k in ka:0){
if (ka>0){  #all directions
direction<- 2*as.numeric(c(1,intToBits(k)[1:(d-1)]))-1   #vector of signs, first element always plus 1
if (k!=ka)  { # direction does not consist of only ones
sel<- which(direction<0)
sela<- setdiff(1:d,sel) #selected columns for direction>0
u[,sel]<- -uu[,sel]
u[,sela]<- uu[,sela]
}
} else {  #  one direction
sel<- which(direction<0)
u[,sel]<- -uu[,sel]
}
v<- cbind(u,y)
A<-(sum(F.n(u,u,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #denominator
B<-(sum(F.n(v,v,offset = 0, smoothing = "none"))-1.0)/(nn-1.0) #numerator
if (out==1){   # output of all coefficients
if (A==0.0) {ret[[k+1]]<- list(dcoeff="not defined",dir=direction)
}else{ret[[k+1]]<- list(dcoeff=2*B/A-1.0,dir=direction)}  #An,Bn,
}else{
if (A!=0.0){  ## reduced output of the largest absolut value
h<- 2*B/A-1.0
if (abs(h)>msr) {
msr<- abs(h)
ret[[1]]<- list(dcoeff=h,dir=direction)
}
}
}
}
return(ret)
}
microbenchmark(
kendr1(daten[,c(1,2,3)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
microbenchmark(
kendr1(daten[,c(1,2,3,4,5,7,8,9)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
microbenchmark(
kendr(daten[,c(1,2,3,4,5,7,8,9)],daten[,6]),
times = 1000  # Anzahl der Wiederholungen
)
kendr(daten[,c(1,2,3,4,5,7,8,9)],daten[,6])
kendr1(daten[,c(1,2,3,4,5,7,8,9)],daten[,6])
kendr1(daten[,c(1,2,3,4,5)],daten[,6])
kendr1(daten[,c(1,2,3,4)],daten[,6])
kendr(daten[,c(1,2,3,4)],daten[,6])
subsets(4)
sets::subsets(4)
install.packages("sets")
sets::subsets(4)
library(sets)
sets::subsets(4)
subsets(4)
expand.grid(1:4)
expand.grid(1:4,1:4)
shiny::runApp('O:/Eckhard/stat/R/zuverl/beschleun_lebensd')
runApp('O:/Eckhard/stat/R/zuverl/beschleun_lebensd')
runApp('O:/Eckhard/stat/R/zuverl/beschleun_lebensd')
runApp('O:/Eckhard/stat/R/zuverl/beschleun_lebensd')
