;$Id: d_pca.pro,v 1.11 2001/01/15 22:26:39 scottm Exp $ ; ; Copyright (c) 1997-2001, Research Systems, Inc. All rights reserved. ; Unauthorized reproduction prohibited. ; ;+ ; FILE: ; d_pca.pro ; ; CALLING SEQUENCE: d_pca ; ; PURPOSE: ; This demo shows the various plots in IDL made from 2-D data. ; ; MAJOR TOPICS: Data analysis and plotting ; ; CATEGORY: ; IDL Demo System ; ; INTERNAL FUNCTIONS and PROCEDURES: ; pro d_pcaEvent - Event handler ; pro d_pcaCleanup - Cleanup ; pro d_pca - Main procedure ; ; EXTERNAL FUNCTIONS, PROCEDURES, and FILES: ; pca.tip ; pro demo_gettips - Read the tip file and create widgets ; ; REFERENCE: IDL Reference Guide, IDL User's Guide ; ; NAMED STRUCTURES: ; none. ; ; COMMON BLOCS: ; none. ; ; MODIFICATION HISTORY: ; 98, ACY - Written. ;- ; ----------------------------------------------------------------------------- ; ; ----------------------------------------------------------------------------- ; ; Purpose: Event handler ; pro d_pcaEvent, $ sEvent ; IN: event structure ; Quit the application using the close box. ; if (TAG_NAMES(sEvent, /STRUCTURE_NAME) EQ $ 'WIDGET_KILL_REQUEST') then begin WIDGET_CONTROL, sEvent.top, /DESTROY RETURN endif ; Get the info structure from top-level base. ; WIDGET_CONTROL, sEvent.top, GET_UVALUE=sState, /NO_COPY ; Determine which event. ; WIDGET_CONTROL, sEvent.id, GET_UVALUE=eventval ; Take the following action based on the corresponding event. ; case eventval of 'EigenValues': begin ; Check if the plot already exists ; errorStatus = WIDGET_INFO(sState.drawEigenValID, /VALID_ID) if (errorStatus EQ 0) then begin ; Create a new window that displays the error plot. ; eigenValBase = WIDGET_BASE(TLB_FRAME_ATTR=1, $ TITLE ='Eigenvalue Plot', $ XOFFSET=75, YOFFSET=75, $ GROUP_LEADER=sState.wTopBase) sState.drawEigenValID = WIDGET_DRAW(eigenValBase, $ SCR_XSIZE=250, SCR_YSIZE=200) WIDGET_CONTROL, eigenValBase, /REALIZE endif WIDGET_CONTROL, sState.drawEigenValID, GET_VALUE=eigenValWindow WSET, eigenValWindow WSHOW, eigenValWindow PLOT, sState.eigenvalues, color = 30, background = 255, thick = 2, $ xtitle = 'Variables', ytitle = 'Eigenvalues', ticklen = -0.02, $ xstyle = 10, ystyle = 10, Xmargin=[7,1],YMargin=[4,1], $ xminor = -1, yminor = -1 OPLOT, sState.eigenvalues, color = 120, psy = 2, symsize = 1.5 WIDGET_CONTROL, sEvent.top, SET_UVALUE=sState, /NO_COPY end 'Variances': begin void = DIALOG_MESSAGE([$ ['Variance Summary'], $ [' '], $ ['1st Derived Variable: ' + STRING(sState.variances[0])], $ [' '], $ ['2nd Derived Variable:'+ STRING(sState.variances[1])], $ [' '], $ ['3rd Derived Variable: ' + STRING(sState.variances[2])], $ [' '], $ ['4th Derived Variable: ' + STRING(sState.variances[3])], $ [' '], $ ['5th Derived Variable: ' + STRING(sState.variances[4])], $ [' '], $ ['TOTAL Variance: ' + STRING(TOTAL(sState.variances[0:4]))]], $ title = 'Principal Components Analysis', /information) WIDGET_CONTROL, sEvent.top, SET_UVALUE=sState, /NO_COPY end "ABOUT": begin ; Display the information. ; topicNum = 3210 ;; pca ONLINE_HELP, topicNum, /CONTEXT, $ book=demo_filepath("idl_demo.hlp", $ SUBDIR=['examples','demo','demohelp']), $ /FULL_PATH ; Restore the info structure ; WIDGET_CONTROL, sEvent.top, SET_UVALUE=sState, /NO_COPY end "QUIT": begin ; Restore the info structure before destroying event.top ; WIDGET_CONTROL, sEvent.top, SET_UVALUE=sState, /NO_COPY ; Destroy widget hierarchy. ; WIDGET_CONTROL, sEvent.top, /DESTROY end ELSE : begin PRINT, 'Case Statement found no matches' ; Restore the info structure ; WIDGET_CONTROL, sEvent.top, Set_UValue=info, /No_Copy end endcase end ; of d_pcaEvent ; ----------------------------------------------------------------------------- ; ; Purpose: Cleanup procedure ; pro d_pcaCleanup, $ wTopBase ; IN: top level base associated with the cleanup ; Get the color table saved in the window's user value. ; WIDGET_CONTROL, wTopBase, GET_UVALUE=sState,/No_Copy ; Restore the previous color table. ; TVLCT, sState.colorTable ; Map the group leader base if it exists. ; if (WIDGET_INFO(sState.groupBase, /VALID_ID)) then $ WIDGET_CONTROL, sState.groupBase, /MAP end ; of d_pcaCleanup ; ----------------------------------------------------------------------------- ; ; Purpose: Main procedure of the pca demo ; pro d_pca, $ GROUP=group, $ ; IN: (opt) group identifier RECORD_TO_FILENAME=record_to_filename, $ APPTLB = appTLB ; OUT: (opt) TLB of this application ; Check the validity of the group identifier ; ngroup = N_ELEMENTS(group) if (ngroup NE 0) then begin check = WIDGET_INFO(group, /VALID_ID) if (check NE 1) then begin print,'Error, the group identifier is not valid' print, 'Return to the main application' RETURN endif groupBase = group endif else groupBase = 0L ; Get the screen size. ; Device, GET_SCREEN_SIZE = screenSize ; Set up dimensions of the drawing (viewing) area. ; xdim = screenSize[0]*0.8 / 2.0 ydim = xdim ; Make the system have a maximum of 256 colors ; numcolors = !d.N_COLORS if( (( !D.NAME EQ 'X') or (!D.NAME EQ 'MAC')) $ and (!d.N_COLORS GE 256L)) then $ DEVICE, PSEUDO_COLOR=8 DEVICE, DECOMPOSED=0, BYPASS_TRANSLATION=0 ; Get the current color table ; TVLCT, savedR, savedG, savedB, /GET ; Build color table from color vectors ; colorTable = [[savedR],[savedG],[savedB]] ; Get the data filename = demo_filepath("pca_med.dat", $ SUBDIR=['examples','demo','demodata']) N_Variables = 50 & N_Samples = 230 data = FLTARR(N_Variables, N_Samples, /NOZERO) OPENR, lun, /GET_LUN, filename, /XDR READU, lun, data FREE_LUN, lun variances = 1 & eigenvalues = 1 ;Since PCOMP is an iterative routine, floating underflow ;of a result is expected. Floating underflow occurs when ;a result is so close to zero that it cannot be represented ;as a normalized floating point value. This occurs during ;convergence in the iterative routine since the delta between ;two steps will be very small. ;Silently accumulate any subsequent math errors and ignore them. orig_except = !except !except = 0 pcadata = PCOMP(standardize(data, /double), $ eigenvalues = eigenvalues, variances = variances, /double) ignore = check_math() ; Get status and reset. ;Restore original math error behavior. !except = orig_except ; Get the character scaling factor ; charscale = 8.0/!d.X_CH_SIZE ; Load a color table, reserve the last 9 colors for annotation ; LOADCT, 5, /SILENT maxImage = !D.TABLE_SIZE-9 ; maximum number of color for plots ; Load 8 tek colors, the last color index is the ; one from the original color table. ; TEK_COLOR, maxImage, 8 ; Create the starting up message. ; if (ngroup EQ 0) then begin drawbase = demo_startmes() endif else begin drawbase = demo_startmes(GROUP=group) endelse ; Define a main widget base. ; if (N_ELEMENTS(group) EQ 0) then begin wTopBase = WIDGET_BASE(TITLE="Pca Plotting", /COLUMN, $ /TLB_KILL_REQUEST_EVENTS, $ MAP=0, $ TLB_FRAME_ATTR=1, MBAR=barBase) endif else begin wTopBase = WIDGET_BASE(TITLE="Pca Plotting", /COLUMN, $ /TLB_KILL_REQUEST_EVENTS, $ MAP=0, $ GROUP_LEADER=group, $ TLB_FRAME_ATTR=1, MBAR=barBase) endelse ; Create the quit button ; wFileButton = WIDGET_BUTTON(barBase, VALUE= 'File', /MENU) wQuitButton = WIDGET_BUTTON(wFileButton, $ VALUE='Quit', UVALUE='QUIT') wOptionButton = WIDGET_BUTTON(barBase, VALUE='Options', /MENU) wEigenval = WIDGET_BUTTON(wOptionButton, $ VALUE="Show Eigenvalues", $ UVALUE='EigenValues') wDescripButton = WIDGET_BUTTON(wOptionButton, $ VALUE="Show Variances", $ UVALUE='Variances') ; Create the help button ; wHelpButton = WIDGET_BUTTON(barBase, /HELP, $ VALUE='About', /MENU) wAboutButton = WIDGET_BUTTON(wHelpButton, $ VALUE='About Principal Components Analysis', UVALUE='ABOUT') ; Create the first child of the top level base ; wTopRowBase = WIDGET_BASE(wTopBase, COLUMN=2, /FRAME) ; Create a base for the left column ; wLeftBase = WIDGET_BASE(wTopRowBase, /COLUMN) label = WIDGET_LABEL(wLeftBase, value = 'Multivariate Data',$ /align_center) wDraw1 = WIDGET_DRAW(wLeftBase, scr_xsize = xdim, $ scr_ysize = ydim, /frame, retain=2) clabels = STRARR(N_Variables) for k = 1, N_Variables do clabels[k-1] = 'Variable ' + $ STRTRIM(STRING(k),2) rlabels = STRARR(N_Samples) for k = 1, N_Samples do rlabels[k-1] = 'Sample ' + $ STRTRIM(STRING(k),2) table = WIDGET_TABLE(wLeftBase, value = data, $ frame = 10, column_labels = clabels, $ row_labels = rlabels, $ x_scroll_size = 2, y_scroll_size = 3, /scroll) ; Create a base for the right column ; wRightBase = WIDGET_BASE(wTopRowBase, /COLUMN) label = WIDGET_LABEL(wRightBase, $ value = 'Principal Components Data', $ /align_center) wDraw2 = WIDGET_DRAW(wRightBase, scr_xsize = xdim, $ scr_ysize = ydim, /frame, retain=2) table = WIDGET_TABLE(wRightBase, value = pcadata, $ frame = 10, column_labels = clabels, $ row_labels = rlabels, $ x_scroll_size = 2, y_scroll_size = 3, /scroll) ; Create tips texts. ; wStatusBase = WIDGET_BASE(wTopBase, MAP=0, /ROW) ; Realize the widget hierarchy. ; WIDGET_CONTROL, wTopBase, /REALIZE widget_control, wDraw1, get_value=window1 wset, window1 SURFACE, data, xtitle = 'V a r i a b l e s', $ ytitle = 'S a m p l e s', $ bottom = 128, background = 255, color = 15, $ xstyle = 1, ystyle = 1, zstyle = 1, $ xmargin = [4, 2], ymargin = [2, 0], ax = 40, $ charsize = 1.5, charthick = 1, $ xminor = -1, yminor = -1, zminor = -1 widget_control, wDraw2, get_value=window2 wset, window2 SURFACE, pcadata, xtitle = 'V a r i a b l e s', $ ytitle = 'S a m p l e s', $ bottom = 128, background = 255, color = 15, $ xstyle = 1, ystyle = 1, zstyle = 1, $ xmargin = [4, 2], ymargin = [2, 0], ax = 40, $ charsize = 1.5, charthick = 1, $ xminor = -1, yminor = -1, zminor = -1 ; Returns the top level base in the appTLB keyword. ; appTLB = wTopBase ; Get the tips ; sText = demo_getTips(demo_filepath('pca.tip', $ SUBDIR=['examples','demo', 'demotext']), $ wTopBase, $ wStatusBase) WIDGET_CONTROL, wTopBase, SENSITIVE=0 ; Create the info structure ; sState={ colorTable: colorTable, $ ; color table to restore wDraw1: wDraw1, $ ; Draw window ID wDraw2: wDraw2, $ ; Draw window ID WHelpButton: wHelpButton, $ ; Help button ID WQuitButton: wQuitButton, $ ; Quit button ID WFileButton: wFileButton, $ ; File button ID WTopBase: wTopBase, $ ; Top level base ID WLeftBase: wLeftBase, $ ; Left base ID WStatusBase: wStatusBase, $ ; Statusbase ID drawEigenValID: 0L, $ ; id of eigenval draw eigenvalues: eigenvalues, $ variances: variances, $ groupBase: groupBase $ ; Base of Group Leader } ; Register the info structure in the user value of the top-level base ; WIDGET_CONTROL, wTopBase, SET_UVALUE=sState, /NO_COPY WIDGET_CONTROL, wTopBase, SENSITIVE=1 ; Destroy the starting up window. ; WIDGET_CONTROL, drawbase, /DESTROY ; Map the top level base. ; WIDGET_CONTROL, wTopBase, MAP=1 XMANAGER, "Template", wTopBase, $ /NO_BLOCK, $ EVENT_HANDLER="d_pcaEvent", CLEANUP="d_pcaCleanup" end ; main procedure