R/plot.ndrlm.R

In kzst/nda: Generalized Network-Based Dimensionality Reduction and Analysis

#-----------------------------------------------------------------------------#
#                                                                             #
#  GENERALIZED NETWORK-BASED DIMENSIONALITY REDUCTION AND ANALYSIS (GNDA)     #
#                                                                             #
#  Written by: Zsolt T. Kosztyan*, Marcell T. Kurbucz, Attila I. Katona,      #
#              Zahid Khan                                                     #
#              *Department of Quantitative Methods                            #
#              University of Pannonia, Hungary                                #
#              kosztyan.zsolt@gtk.uni-pannon.hu                               #
#                                                                             #
# Last modified: February 2024                                                #
#-----------------------------------------------------------------------------#
### PLOT FOR NETWORK-BASED DIMENSIONALITY REDUCTION AND REGRESSION (NDRLM) ####
#' @export
plot.ndrlm <- function(x,sig=0.05,interactive=FALSE,...){
  if (methods::is(x,"ndrlm")){
    if (!requireNamespace("igraph", quietly = TRUE)) {
      stop(
        "Package \"igraph\" must be installed to use this function.",
        call. = FALSE
      )
    }
    if (!requireNamespace("stats", quietly = TRUE)) {
      stop(
        "Package \"stats\" must be installed to use this function.",
        call. = FALSE
      )
    }
    if (!requireNamespace("visNetwork", quietly = TRUE)) {
      stop(
        "Package \"visNetwork\" must be installed to use this function.",
        call. = FALSE
      )
    }
    if (!requireNamespace("lm.beta", quietly = TRUE)) {
      stop(
        "Package \"lm.beta\" must be installed to use this function.",
        call. = FALSE
      )
    }
    latents<-x$latents
    extra_vars.X<-x$extra_vars.X
    extra_vars.Y<-x$extra_vars.Y

    X<-x$X
    Y<-x$Y

    nY<-ncol(x$Y)
    nSin<-0
    if (latents %in% c("in","both")){
      nSin<-ncol(x$NDAin$scores)
      membership.X<-x$NDAin$membership
      loadings.X<-x$NDAin$loadings
    }
    nSout<-0
    if (latents %in% c("out","both")){
      nSout<-ncol(x$NDAout$scores)
      membership.Y<-x$NDAout$membership
      loadings.Y<-x$NDAout$loadings
    }
    nX<-ncol(x$X)

    node_ID<-1:(nY+nSout+nSin+nX)
    node_label<-c(colnames(x$Y),
                  unlist(ifelse(latents %in% c("out","both"),
                    list(paste("NDAout",1:x$NDAout$factors,sep="")),
                    list(NULL))),
                  unlist(ifelse(latents %in% c("in","both"),
                    list(paste("NDAin",1:x$NDAin$factors,sep="")),
                    list(NULL))),colnames(x$X))

    node_shape<-c(rep("rectangle",nY),
                  unlist(ifelse(latents %in% c("out","both"),
                                list(rep("circle",nSout)),
                                list(NULL))),
                  unlist(ifelse(latents %in% c("in","both"),
                                list(rep("circle",nSin)),
                                list(NULL))),
                  rep("rectangle",nX))

    node_color<-c(unlist(ifelse(latents %in% c("out","both"),
                                 list(x$NDAout$membership),
                                 list(rep(0,nY)))),
                   unlist(ifelse(latents %in% c("out","both"),
                                 list(1:nSout),
                                 list(NULL))),
                   unlist(ifelse(latents %in% c("in","both"),
                                 list(1:nSin),
                                 list(NULL))),
                   unlist(ifelse(latents %in% c("in","both"),
                                 list(x$NDAin$membership),
                                 list(rep(0,nX)))))
    nodes<-data.frame(id=node_ID,label=node_label,shape=node_shape,
                      color=node_color)
    edges <- data.frame(matrix(ncol = 6, nrow = 0))
    colnames(edges) <- c('from', 'to', 'weight' , 'color' , 'lty' , 'dashes')

    dep<-Y
    if (latents %in% c("out","both")){
      if (extra_vars.Y==TRUE){
        dep<-cbind(x$NDAout$scores,x$Y[,x$NDAout$membership==0])
        dep<-as.data.frame(dep)
        colnames(dep)<-c(paste("NDAout",1:x$NDAout$factors,sep=""),
                         colnames(x$Y)[x$NDAout$membership==0])
      }else{
        dep<-x$NDAout$scores
        colnames(dep)<-paste("NDAout",1:x$NDAout$factors,sep="")
      }
    }
    indep<-X
    if (latents %in% c("in","both")){
      if (extra_vars.X==TRUE){
        indep<-cbind(x$NDAin$scores,x$X[,x$NDAin$membership==0])
        indep<-as.data.frame(indep)
        colnames(indep)<-c(paste("NDAin",1:x$NDAin$factors,sep=""),
                         colnames(x$X)[x$NDAin$membership==0])



      }else{
        indep<-x$NDAin$scores
        colnames(indep)<-paste("NDAin",1:x$NDAin$factors,sep="")
      }
    }

    k<-1
    for (i in 1:length(x$fits)){
      coefs<-as.vector(lm.beta::lm.beta(x$fits[[i]])$standardized.coefficients)[-1]
      pvalues<-summary(x$fits[[i]])$coefficients[-1,4]
      indepvars<-colnames(x$fits[[i]]$model)[-1]
      depvar<-colnames(x$fits[[i]]$model)[1]
      for (j in 1:length(coefs)){
        if (pvalues[j]<sig){
          edges[k,"to"]<-node_ID[node_label %in% depvar]
          edges[k,"from"]<-node_ID[node_label %in% indepvars[j]]
          edges[k,"weight"]<-coefs[j]
          edges[k,"color"]<-"black"
          edges[k,"lty"]<-"solid"
          edges[k,"dashes"]<-FALSE
          k<-k+1
        }
      }
    }

    if (latents %in% c("in","both")){
      membership.X<-x$NDAin$membership
      for (i in 1:nSin){
        for (j in 1:length(membership.X)){
          if (membership.X[j]==i){
            edges[k,"from"]<-node_ID[node_label %in% colnames(x$X)[j]]
            edges[k,"to"]<-node_ID[node_label %in% paste("NDAin",i,sep="")]
            edges[k,"weight"]<-loadings.X[colnames(x$X)[j],i]
            edges[k,"color"]<-"grey"
            edges[k,"lty"]<-"dashed"
            edges[k,"dashes"]<-TRUE
            k<-k+1
          }
        }
      }
    }

    if (latents %in% c("out","both")){
      membership.Y<-x$NDAout$membership
      for (i in 1:nSout){
        for (j in 1:length(membership.Y)){
          if (membership.Y[j]==i){
            edges[k,"from"]<-node_ID[node_label %in% colnames(x$Y)[j]]
            edges[k,"to"]<-node_ID[node_label %in% paste("NDAout",i,sep="")]
            edges[k,"weight"]<-loadings.Y[colnames(x$Y)[j],i]
            edges[k,"color"]<-"grey"
            edges[k,"lty"]<-"dashed"
            edges[k,"dashes"]<-TRUE
            k<-k+1
          }
        }
      }
    }


    space=150
    cust_layout<-matrix(0,ncol=2,nrow=nY+nSin+nSout+nX)
    cust_layout[1:nY,1]<-3
    if (latents %in% c("out","both")){
      cust_layout[sort(membership.Y,index.return=TRUE)$ix,2]<-((1:nY)-mean(1:nY))*space
    }else{
      cust_layout[1:nY,2]<-((1:nY)-mean(1:nY))*space
    }

    if (latents %in% c("out","both")){
      cust_layout[(nY+1):(nY+nSout),1]<-2
      cust_layout[(nY+1):(nY+nSout),2]<-((1:nSout)-mean(1:nSout))*space
    }

    if (latents %in% c("in","both")){
      cust_layout[(nY+nSout+1):(nY+nSin+nSout),1]<-1
      cust_layout[(nY+nSout+1):(nY+nSin+nSout),2]<-((1:nSin)-mean(1:nSin))*space
    }

    cust_layout[(nY+nSin+nSout+1):(nY+nSin+nSout+nX),1]<-0
    if (latents %in% c("in","both")){
      cust_layout[sort(membership.X,index.return=TRUE)$ix+nY+nSin+nSout,2]<-((1:nX)-mean(1:nX))*space
    }else{
      cust_layout[(nY+nSin+nSout+1):(nY+nSin+nSout+nX),2]<-((1:nX)-mean(1:nX))*space
    }


    G<-igraph::graph_from_data_frame(edges,
                             directed=TRUE,
                             vertices=nodes)

    if (interactive==TRUE){
      edges$arrows<-ifelse(igraph::is.directed(G),c("to"),"")
      edges$width<-(abs(igraph::E(G)$weight))
      nodes$color<-grDevices::hsv((node_color+1)/max(node_color+1),
                                  alpha=0.4)
      nodes$shape<-gsub("rectangle","box",nodes$shape)
      nodes$shape<-gsub("circle","ellipse",nodes$shape)
      edges$label<-as.vector(paste(round(edges$weight,2),sep=""))
      nw <-
        visNetwork::visIgraphLayout(
          visNetwork::visNodes(
            visNetwork::visInteraction(
              visNetwork::visOptions(
                visNetwork::visEdges(
                  visNetwork::visNetwork(
                    nodes, edges, height = "1000px", width = "100%"),
                  font = list(size = 6),color="#555555",
                  label=edges$label),
                highlightNearest = TRUE, selectedBy = "label"),
              dragNodes = TRUE,
              dragView = TRUE,
              zoomView = TRUE,
              hideEdgesOnDrag = FALSE),physics=FALSE, size=16,
            borderWidth = 1,
            shape=nodes$shape,
            font=list(face="calibri")),layout="layout.norm",
          layoutMatrix = cust_layout,
          physics = FALSE, type="full"
        )
      nw
      return(nw)

    }else{
      igraph::V(G)$color<-grDevices::hsv((node_color+1)/max(node_color+1),
                                  alpha=0.4)
      igraph::plot.igraph(G,layout=cust_layout,edge.width=abs(igraph::E(G)$weight)*5,
           edge.label=round(igraph::E(G)$weight,2),vertex.size=50)

      #ggraph(G, layout = cust_layout, circular = FALSE) +
      #  geom_edge_diagonal(arrow = arrow(angle = 8, length = unit(0.10, "inches"),
      #                                   ends = "last", type = "closed"),width=0.1) +
      #  geom_node_point(size=10,aes(color=V(G)$color,
      #                      shape=factor(V(G)$shape,
      #                                   labels=c("circle","rectangle")))) +
      #  scale_shape_manual (labels = c("latents","indicators"),
      #                      values = c(16,15)) +
      #  scale_color_distiller(palette="Set3") +
      #  guides(shape = guide_legend(""),
      #         color=guide_none(),
      #         size = guide_none()) +
      #  geom_node_text (aes (label = label),
      #  hjust = -0.1, vjust = 0.5,size=4,
      #                  colour = "#3333AA") +
      #  theme(legend.position = "bottom",
      #        panel.background = element_rect(fill="white"),
      #        plot.margin = margin(3, 3, 3, 3, "cm"))
      return(G)
    }

  }else{
    plot(x,...)
  }
}